From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 22 Oct 2019 06:00:09 +0000 (-0700)
Subject: Create a "standard" library providing access to the library database.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~25
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=78f5b6cb7591c102a4b50a9cf65b98db0a91911e;p=mit-scheme.git

Create a "standard" library providing access to the library database.

This is useful for programs that want to work directly on libraries.
---

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