From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 10 Jun 2018 03:51:54 +0000 (-0700)
Subject: Not-yet-complete implementation of R7RS libraries.
X-Git-Tag: mit-scheme-pucked-9.2.15~11^2~2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=71cf6bfa4bc48acf4989c6a29859e615296a1f27;p=mit-scheme.git

Not-yet-complete implementation of R7RS libraries.
---

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index 7741ea368..6f3066601 100644
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -30,6 +30,40 @@ USA.
 (declare (usual-integrations))
 
 (define (make-library-db)
+  (let ((compiled (make-library-table))
+	(loaded (make-library-table)))
+
+    (define (compiled? name)
+      (compiled 'has? name))
+
+    (define (get-compiled name #!optional default-value)
+      (compiled 'get name default-value))
+
+    (define (save-compiled! library)
+      (compiled 'put! (compiled-library-name library) library))
+
+    (define (require-compiled names)
+      (let ((unknown (remove compiled? names)))
+	(if (pair? unknown)
+	    (error "Can't resolve libraries:" unknown))))
+
+    (define (loaded? name)
+      (loaded 'has? name))
+
+    (define (get-loaded name #!optional default-value)
+      (loaded 'get name default-value))
+
+    (define (save-loaded! library)
+      (loaded 'put! (loaded-library-name library) library))
+
+    (bundle library-db?
+	    compiled? get-compiled save-compiled! require-compiled
+	    loaded? get-loaded save-loaded!)))
+
+(define library-db?
+  (make-bundle-predicate 'library-database))
+
+(define (make-library-table)
   (let ((table (make-equal-hash-table)))
 
     (define (has? name)
@@ -54,7 +88,7 @@ USA.
 		  (put! (car p) (cdr p)))
 		alist*))
 
-    (bundle library-db? has? get put! delete! get-alist put-alist!)))
+    (bundle library-table? has? get put! delete! get-alist put-alist!)))
 
-(define library-db?
-  (make-bundle-predicate 'library-database))
\ No newline at end of file
+(define library-table?
+  (make-bundle-predicate 'library-table))
\ No newline at end of file
diff --git a/src/runtime/library-imports.scm b/src/runtime/library-imports.scm
new file mode 100644
index 000000000..9298307f7
--- /dev/null
+++ b/src/runtime/library-imports.scm
@@ -0,0 +1,142 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; R7RS libraries: imports
+;;; package: (runtime library imports)
+
+(declare (usual-integrations))
+
+(define (convert-import-sets import-sets library-db)
+  (library-db 'require-compiled (import-sets->libraries import-sets))
+  (let ((converted-sets
+	 (map (lambda (import-set)
+		(convert-import-set import-set library-db))
+	      import-sets)))
+    (let ((intersections (find-intersections converted-sets)))
+      (if (pair? intersections)
+	  (error "Import sets intersect:"
+		 (unconvert-intersections intersections
+					  converted-sets
+					  import-sets))))
+    (append-map (lambda (set) set) converted-sets)))
+
+(define (import-sets->libraries import-sets)
+  (delete-duplicates (append-map import-set->library import-sets)
+		     equal?))
+
+(define (import-set->library import-set)
+  (case (car import-set)
+    ((library) (cadr import-set))
+    ((only except prefix rename) (import-set->library (cadr import-set)))
+    (else (error "Unrecognized import set:" import-set))))
+
+(define (find-intersections converted-sets)
+  (if (pair? converted-sets)
+      (let* ((links1 (car converted-sets))
+	     (names1 (map library-import-to links1)))
+	(append (filter-map (lambda (links2)
+			      (and (intersecting-names?
+				    names1
+				    (map library-import-to links2))
+				   (list links1 links2)))
+			    (cdr converted-sets))
+		(find-intersections converted-sets)))
+      '()))
+
+(define (intersecting-names? names1 names2)
+  (pair? (lset-intersection eq? names1 names2)))
+
+(define (unconvert-intersections intersections converted-sets imported-sets)
+  (let ((alist (map cons converted-sets imported-sets)))
+    (map (lambda (intersection)
+	   (map (lambda (converted-set)
+		  (cdr (assq converted-set alist)))
+		intersection))
+	 intersections)))
+
+;;; Returns a list of (<to-name> <from-name> <from-library>) elements.
+(define (convert-import-set import-set library-db)
+  (let ((converted-set
+	 (let loop ((import-set import-set) (filter (lambda (name) name)))
+	   (case (car import-set)
+	     ((library)
+	      (let ((library-name (cadr import-set)))
+		(filter-map (lambda (export)
+			      (let* ((name (library-export-to export))
+				     (filtered (filter name)))
+				(and filtered
+				     (make-library-import filtered
+							  name
+							  library-name))))
+			    (compiled-library-exports
+			     (library-db 'get-compiled library-name)))))
+	     ((only)
+	      (loop (cadr import-set)
+		    (let ((names (cddr import-set)))
+		      (lambda (name)
+			(and (memq name names)
+			     (filter name))))))
+	     ((except)
+	      (loop (cadr import-set)
+		    (let ((names (cddr import-set)))
+		      (lambda (name)
+			(and (not (memq name names))
+			     (filter name))))))
+	     ((prefix)
+	      (loop (cadr import-set)
+		    (let ((prefix (caddr import-set)))
+		      (lambda (name)
+			(filter (symbol prefix name))))))
+	     ((rename)
+	      (loop (cadr import-set)
+		    (let ((renames (cddr import-set)))
+		      (lambda (name)
+			(filter
+			 (let ((p (assq name renames)))
+			   (if p
+			       (cdr p)
+			       name)))))))
+	     (else
+	      (error "Unrecognized import set:" import-set))))))
+    (if (duplicate-names? (map library-import-to converted-set))
+	(error "Import set has duplicate names:" import-set))
+    converted-set))
+
+(define (duplicate-names? names)
+  (and (pair? names)
+       (let loop ((names (sort names symbol<?)))
+	 (and (pair? (cdr names))
+	      (or (eq? (car names) (cadr names))
+		  (loop (cdr names)))))))
+
+(define (make-library-import to from from-library) (list to from from-library))
+(define (library-import-to import) (car import))
+(define (library-import-from import) (cadr import))
+(define (library-import-from-library import) (caddr import))
+
+(define (make-library-export from to) (cons from to))
+(define (library-export-from export) (car export))
+(define (library-export-to export) (cdr export))
\ No newline at end of file
diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
new file mode 100644
index 000000000..3ec702e7f
--- /dev/null
+++ b/src/runtime/library-loader.scm
@@ -0,0 +1,169 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; R7RS libraries: loader
+;;; package: (runtime library loader)
+
+(declare (usual-integrations))
+
+;;;; Compile
+
+(define (compile-library form library-db)
+  (let ((library (parse-define-library-form form)))
+    (let ((imports
+	   (convert-import-sets (parsed-library-imports library)
+				library-db)))
+      (make-compiled-library (parsed-library-name library)
+			     imports
+			     (parsed-library-exports library)
+			     (compile-contents library library-db)))))
+
+(define (compile-contents library library-db)
+  (let ((imports (parsed-library-imports library))
+	(exports (parsed-library-exports library)))
+    (receive (body bound free)
+	(syntax-library-forms
+	 (append-map (lambda (directive)
+		       (case (car directive)
+			 ((include)
+			  (fluid-let ((param:reader-fold-case? #f))
+			    (append-map (lambda (pathname)
+					  (call-with-input-file pathname
+					    read-file))
+					(cdr directive))))
+			 ((include-ci)
+			  (fluid-let ((param:reader-fold-case? #t))
+			    (append-map (lambda (pathname)
+					  (call-with-input-file pathname
+					    read-file))
+					(cdr directive))))
+			 ((begin)
+			  (cdr directive))
+			 (else
+			  (error "Unknown content directive:" directive))))
+		     (parsed-library-contents library))
+	 (converted-imports->environment imports library-db))
+      (let ((exports-from (map library-export-from exports)))
+	(if (not (lset<= eq? exports-from (lset-union eq? bound free)))
+	    (warn "Library export refers to unbound identifiers:"
+		  (lset-difference eq?
+				   exports-from
+				   (lset-union eq? bound free)))))
+      (let ((imports-to (map library-import-to imports)))
+	(if (not (lset<= eq? free imports-to))
+	    (warn "Library has free references not provided by imports:"
+		  (lset-difference eq? free imports-to))))
+      body)))
+
+(define-record-type <compiled-library>
+    (make-compiled-library name imports exports body)
+    compiled-library?
+  (name compiled-library-name)
+  (imports compiled-library-imports)
+  (exports compiled-library-exports)
+  (body compiled-library-body))
+
+(define (compiled-library->scode library)
+  (make-scode-declaration
+   `(target-metadata
+     (library (name ,(compiled-library-name library))
+	      (imports ,(compiled-library-imports library))
+	      (exports ,(compiled-library-exports library))))
+   (make-scode-quotation (compiled-library-body library))))
+
+;;;; Load
+
+(define (load-library library-name library-db)
+  (or (library-db 'get-loaded library-name #f)
+      (let ((compiled (library-db 'get-compiled library-name)))
+	(let ((environment
+	       (converted-imports->environment
+		(compiled-library-imports compiled)
+		library-db)))
+	  (scode-eval (compiled-library-body compiled)
+		      environment)
+	  (make-loaded-library (compiled-library-name compiled)
+			       (compiled-library-exports compiled)
+			       environment
+			       library-db)))))
+
+(define (make-loaded-library name exports environment library-db)
+  (let ((library
+	 (%make-loaded-library name
+			       (map library-export-to exports)
+			       (make-exporter exports environment)
+			       environment)))
+    (library-db 'save-loaded! library)
+    library))
+
+(define (make-exporter exports environment)
+  (let ((export-alist
+	 (map (lambda (export)
+		(cons (library-export-to export)
+		      (environment-safe-lookup environment
+					       (library-export-from export))))
+	      exports)))
+    (lambda (name)
+      (let ((p (assq name export-alist)))
+	(if (not p)
+	    (error "Not an exported name:" name))
+	(cdr p)))))
+
+(define-record-type <loaded-library>
+    (%make-loaded-library name environment exporter)
+    loaded-library?
+  (name loaded-library-name)
+  (exports loaded-library-exports)
+  (exporter loaded-library-exporter)
+  (environment loaded-library-environment))
+
+(define (library-exporter library-name library-db)
+  (loaded-library-exporter (load-library library-name library-db)))
+
+(define (environment . import-sets)
+  (converted-imports->environment
+   (convert-import-sets (map parse-import-set import-sets))))
+
+(define (converted-imports->environment imports library-db)
+  (let ((env
+	 (make-root-top-level-environment (map library-import-to imports))))
+    (for-each (lambda (import)
+		(let ((value
+		       (library-exporter
+			(library-import-from-library import)
+			library-db))
+		      (name (library-import-to import)))
+		  (cond ((macro-reference-trap? value)
+			 (environment-define-macro
+			  env name
+			  (macro-reference-trap-transformer value)))
+			((unassigned-reference-trap? value)
+			 ;; nothing to do
+			 )
+			(else
+			 (environment-define env name value)))))
+	      imports)
+    env))
\ No newline at end of file
diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm
index 94531da2e..26e42b41a 100644
--- a/src/runtime/library-parser.scm
+++ b/src/runtime/library-parser.scm
@@ -29,37 +29,41 @@ USA.
 
 (declare (usual-integrations))
 
-(define (parse-define-library-form form)
-  (let ((result (%parse-define-library form)))
-    (and result
-	 (let loop
-	     ((decls (expand-parsed-decls (cdr result)))
-	      (exports '())
-	      (imports '())
-	      (contents '()))
-	   (if (pair? decls)
-	       (let ((decl (car decls))
-		     (decls (cdr decls)))
-		 (case (car decl)
-		   ((export)
-		    (loop decls
-			  (append (reverse (cdr decl)) exports)
-			  imports
-			  contents))
-		   ((import)
-		    (loop decls
-			  exports
-			  (append (reverse (cdr decl)) imports)
-			  contents))
-		   (else
-		    (loop decls
-			  exports
-			  imports
-			  (append (reverse (cdr decl)) contents)))))
-	       (make-parsed-library (car result)
-				    (reverse exports)
-				    (reverse imports)
-				    (reverse contents)))))))
+(define (parse-define-library-form form #!optional pathname)
+  (let ((directory
+	 (if (default-object? pathname)
+	     (working-directory-pathname)
+	     (directory-pathname pathname))))
+    (let ((result (%parse-define-library form)))
+      (and result
+	   (let loop
+	       ((decls (expand-parsed-decls (cdr result) pathname))
+		(exports '())
+		(imports '())
+		(contents '()))
+	     (if (pair? decls)
+		 (let ((decl (car decls))
+		       (decls (cdr decls)))
+		   (case (car decl)
+		     ((export)
+		      (loop decls
+			    (append (reverse (cdr decl)) exports)
+			    imports
+			    contents))
+		     ((import)
+		      (loop decls
+			    exports
+			    (append (reverse (cdr decl)) imports)
+			    contents))
+		     (else
+		      (loop decls
+			    exports
+			    imports
+			    (append (reverse (cdr decl)) contents)))))
+		 (make-parsed-library (car result)
+				      (reverse exports)
+				      (reverse imports)
+				      (reverse contents))))))))
 
 (define-record-type <parsed-library>
     (make-parsed-library name exports imports contents)
@@ -69,17 +73,26 @@ USA.
   (imports parsed-library-imports)
   (contents parsed-library-contents))
 
-(define (expand-parsed-decls parsed-decls)
+(define (expand-parsed-decls parsed-decls directory)
   (append-map (lambda (parsed-decl)
 		(case (car parsed-decl)
 		  ((include-library-declarations)
 		   (append-map (lambda (pathname)
-				 (expand-parsed-decls
-				  (get-library-declarations pathname)))
+				 (let ((pathname*
+					(merge-pathnames pathname directory)))
+				   (expand-parsed-decls
+				    (get-library-declarations pathname*)
+				    (directory-pathname pathname*))))
 			       (cdr parsed-decl)))
 		  ((cond-expand)
 		   (expand-parsed-decls
 		    (evaluate-cond-expand eq? parsed-decl)))
+		  ((include include-ci)
+		   (list
+		    (cons (car parsed-decl)
+			  (map (lambda (pathname)
+				 (merge-pathnames pathname directory))
+			       (cdr parsed-decl)))))
 		  (else
 		   (list parsed-decl))))
 	      parsed-decls))
diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index 2b437b02f..12b8fe77e 100644
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -29,20 +29,28 @@ USA.
 
 (declare (usual-integrations))
 
-(define-deferred standard-libraries
-  (make-library-db))
+(define (add-standard-libraries library-db)
+  (for-each (lambda (p)
+	      (make-loaded-library (car p)
+				   (map (lambda (id)
+					  (make-library-export id id))
+					(cdr p))
+				   system-global-environment
+				   library-db))
+	    standard-libraries))
 
 (define (define-standard-library name exports)
-  (add-boot-init!
-   (lambda ()
-     (standard-libraries 'put!
-			 name
-			 (make-parsed-library name
-					      (map (lambda (id)
-						     (cons id id))
-						   exports)
-					      '()
-					      '())))))
+  (let ((p (assoc name standard-libraries)))
+    (if p
+	(set-cdr! p exports)
+	(begin
+	  (set! standard-libraries
+		(cons (cons name exports)
+		      standard-libraries))
+	  unspecific)))
+  name)
+
+(define standard-libraries '())
 
 (define-standard-library '(scheme base)
   '(*
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 498452376..62e55bed9 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -531,8 +531,6 @@ USA.
    (runtime syntax rename)
    (runtime syntax top-level)
    (runtime syntax parser)
-   ;; R7RS Libraries
-   (runtime library standard)
    ;; REP Loops
    (runtime interrupt-handler)
    (runtime gc-statistics)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 368368723..144b7f43b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4486,6 +4486,8 @@ USA.
 	  syntax
 	  syntax*
 	  syntax-error)
+  (export (runtime library)
+	  syntax-library-forms)
   (export (runtime syntax)
 	  biselect-cadr
 	  biselect-car
@@ -4593,6 +4595,7 @@ USA.
 	  make-internal-senv
 	  make-keyword-senv
 	  make-partial-senv
+	  make-sealed-senv
 	  reserve-identifier
 	  senv->runtime
 	  senv-top-level?))
@@ -5820,10 +5823,14 @@ USA.
   (export ()
 	  world-report))
 
+(define-package (runtime library)
+  (files)
+  (parent (runtime)))
+
 (define-package (runtime library parser)
   (files "library-parser")
-  (parent (runtime))
-  (export (runtime)
+  (parent (runtime library))
+  (export (runtime library)
 	  library-name?
 	  make-parsed-library
 	  parse-define-library-form
@@ -5837,13 +5844,49 @@ USA.
 
 (define-package (runtime library database)
   (files "library-database")
-  (parent (runtime))
-  (export (runtime)
+  (parent (runtime library))
+  (export (runtime library)
 	  library-db?
 	  make-library-db))
 
 (define-package (runtime library standard)
   (files "library-standard")
-  (parent (runtime))
-  (export (runtime)
-	  standard-libraries))
\ No newline at end of file
+  (parent (runtime library))
+  (export (runtime library)
+	  add-standard-libraries))
+
+(define-package (runtime library imports)
+  (files "library-imports")
+  (parent (runtime library))
+  (export (runtime library)
+	  convert-import-sets
+	  library-export-from
+	  library-export-to
+	  library-import-from
+	  library-import-from-library
+	  library-import-to
+	  make-library-export))
+
+(define-package (runtime library loader)
+  (files "library-loader")
+  (parent (runtime library))
+  (export ()
+	  environment			;R7RS
+	  )
+  (export (runtime library)
+	  compile-library
+	  compiled-library->scode
+	  compiled-library-body
+	  compiled-library-exports
+	  compiled-library-imports
+	  compiled-library-name
+	  compiled-library?
+	  converted-imports->environment
+	  library-exporter
+	  load-library
+	  loaded-library-environment
+	  loaded-library-exporter
+	  loaded-library-exports
+	  loaded-library-name
+	  loaded-library?
+	  make-loaded-library))
\ No newline at end of file
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 4d7d0f3d3..1991bce5b 100644
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -259,4 +259,53 @@ USA.
 	    (free-senv ,free-senv)
 	    (bound-senv ,bound-senv)))
 
-	(make-senv get-type get-runtime lookup store rename describe))))
\ No newline at end of file
+	(make-senv get-type get-runtime lookup store rename describe))))
+
+;;; Sealed syntactic environments are used for libraries.  A combination of
+;;; top-level and internal syntactic environments, they gather all of the free
+;;; references together so they can be captured by a lambda expression wrapped
+;;; around the body of the library.
+
+(define (make-sealed-senv env)
+  (guarantee environment? env 'make-sealed-senv)
+  (let ((bound '())
+	(free '()))
+
+    (define (get-type)
+      'sealed)
+
+    (define (get-runtime)
+      env)
+
+    (define (lookup identifier)
+      (cond ((or (assq identifier bound)
+		 (assq identifier free))
+	     => cdr)
+	    ((environment-lookup-macro env identifier))
+	    (else
+	     ;; Capture free runtime references:
+	     (let ((item (var-item identifier)))
+	       (set! free (cons (cons identifier item) free))
+	       item))))
+
+    (define (store identifier item)
+      (cond ((assq identifier bound)
+	     => (lambda (binding)
+		  (set-cdr! binding item)))
+	    ((assq identifier free)
+	     (error "Can't define name; already free:" identifier))
+	    (else
+	     (set! bound (cons (cons identifier item) bound))
+	     unspecific)))
+
+    (define (rename identifier)
+      identifier)
+
+    (define (describe)
+      `((bound ,bound)
+	(free ,free)
+	(env ,env)))
+
+    (values (make-senv get-type get-runtime lookup store rename describe)
+	    (lambda () (map car bound))
+	    (lambda () (map car free)))))
\ No newline at end of file
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index b13ace974..31c2ecb4c 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -54,11 +54,24 @@ USA.
 	     (runtime-environment->syntactic environment))))
     (with-identifier-renaming
      (lambda ()
-       (compile-item
-	(body-item #f
-	  (map-in-order (lambda (form)
-			  (classify-form form senv (initial-hist form)))
-			forms)))))))
+       (syntax-internal forms senv)))))
+
+(define (syntax-library-forms forms env)
+  (guarantee list? forms 'syntax-library-forms)
+  (with-identifier-renaming
+   (lambda ()
+     (receive (sealed get-bound get-free) (make-sealed-senv env)
+       (let ((result (syntax-internal forms sealed)))
+	 (values result
+		 (get-bound)
+		 (get-free)))))))
+
+(define (syntax-internal forms senv)
+  (compile-item
+   (body-item #f
+     (map-in-order (lambda (form)
+		     (classify-form form senv (initial-hist form)))
+		   forms))))
 
 ;;;; Classifier