From 78f5b6cb7591c102a4b50a9cf65b98db0a91911e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 21 Oct 2019 23:00:09 -0700
Subject: [PATCH] Create a "standard" library providing access to the library
 database.

This is useful for programs that want to work directly on libraries.
---
 src/runtime/library-standard.scm | 58 +++++++++++++++++++++++++-------
 src/runtime/make.scm             |  2 +-
 src/runtime/runtime.pkg          | 13 +++----
 3 files changed, 53 insertions(+), 20 deletions(-)

diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index bf2c092dc..3259e415b 100644
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -975,28 +975,60 @@ USA.
 (define-standard-library '(srfi 131)
   '(define-record-type))
 
-;;;; Legacy packages
+;;;; Synthetic libraries
 
-(define (initialize-legacy-libraries! package-file)
-  (register-library! (make-library '(mit legacy runtime)
+;;; A synthetic library is one that's derived from legacy packages, much like a
+;;; standard library, with a little more flexibility in where the exports come
+;;; from.
+
+(define (define-synthetic-library name source-package package-pred)
+  (set! synthetic-libraries
+	(cons (list name source-package package-pred)
+	      synthetic-libraries))
+  unspecific)
+
+(define synthetic-libraries '())
+
+(define (package-predicate:name-prefix prefix)
+  (lambda (pd)
+    (let ((name (package-description/name pd)))
+      (and (>= (length name) (length prefix))
+	   (equal? (take name (length prefix)) prefix)))))
+
+(define-synthetic-library '(mit legacy runtime) '()
+  (package-predicate:name-prefix '(runtime)))
+
+(define-synthetic-library '(mit library) '(runtime)
+  (package-predicate:name-prefix '(runtime library)))
+
+(define (initialize-synthetic-libraries! package-file)
+  (for-each (lambda (p)
+	      (let ((name (car p))
+		    (source-package (cadr p))
+		    (package-pred (caddr p)))
+		(make-synthetic-library name
+		  (get-exports package-file source-package package-pred)
+		  (->environment source-package))))
+	    synthetic-libraries))
+
+(define (make-synthetic-library name exports environment)
+  (register-library! (make-library name
 				   'parsed-imports '()
-				   'exports (runtime-exports package-file)
+				   'exports exports
 				   'parsed-contents '()
 				   'filename #f
-				   'environment system-global-environment)
+				   'environment environment)
 		     host-library-db))
 
-(define (runtime-exports package-file)
-  (append-map package-exports
-	      (filter (lambda (pd)
-			(let ((name (package-description/name pd)))
-			  (and (pair? name)
-			       (eq? (car name) 'runtime))))
+(define (get-exports package-file source-package package-pred)
+  (append-map (lambda (pd)
+		(package-exports pd source-package))
+	      (filter package-pred
 		      (vector->list (package-file/descriptions package-file)))))
 
-(define (package-exports pd)
+(define (package-exports pd source-package)
   (filter-map (lambda (link)
-		(and (null? (link-description/package link))
+		(and (equal? source-package (link-description/package link))
 		     (not (link-description/status 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 143a0a54b..1dd45290b 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -621,7 +621,7 @@ USA.
   (write-string "done" (console-i/o-port)))
 
 ((lexical-reference (->environment '(runtime library standard))
-		    'initialize-legacy-libraries!)
+		    'initialize-synthetic-libraries!)
  packages-file)
 
 )
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6ef486df9..9c9bfba31 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -6007,18 +6007,22 @@ USA.
 	  library-contents
 	  library-db?
 	  library-environment
-	  library-imports-used
-	  library-imports
-	  library-name
 	  library-export-from
 	  library-export-to
 	  library-export=?
 	  library-export?
+	  library-filename
 	  library-import-from
 	  library-import-from-library
 	  library-import-to
 	  library-import=?
 	  library-import?
+	  library-imports
+	  library-imports-environment
+	  library-imports-used
+	  library-name
+	  library-parsed-contents
+	  library-parsed-imports
 	  library?
 	  registered-libraries
 	  registered-library
@@ -6032,12 +6036,9 @@ USA.
 	  library-exporter
 	  library-export->list
 	  library-exports
-	  library-filename
 	  library-imports-from
 	  library-import->list
 	  library-imports-environment
-	  library-parsed-contents
-	  library-parsed-imports
 	  library-preregistered?
 	  library-syntaxed-contents
 	  list->library-export
-- 
2.25.1