From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 6 Oct 2018 23:28:42 +0000 (-0700)
Subject: Another rewrite, this time to treat programs as anonymous libraries.
X-Git-Tag: mit-scheme-pucked-9.2.19~2^2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ee9b96914dfcf86b10af113cb11b9a4b764ecbcc;p=mit-scheme.git

Another rewrite, this time to treat programs as anonymous libraries.

This change simplifies handling programs since they can now use the machinery
developed for libraries.  So now r7rs-source is just a combination of some
libraries and an optional program.

Also added property 'imports-environment to get the environment prior to
evaluation.
---

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index 241b585f8..2b43e9404 100644
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -42,11 +42,13 @@ USA.
       (if (and (library 'has? 'db)
 	       (not (eq? (library 'get 'db) this)))
 	  (error "Can't use library in multiple databases:" library))
+      (library 'put! 'db this)
       (let ((name (library 'get 'name)))
-	(if (has? name)
-	    (warn "Overwriting library:" name))
-	(library 'put! 'db this)
-	(hash-table-set! table name library)))
+	(if name
+	    (begin
+	      (if (has? name)
+		  (warn "Overwriting library:" name))
+	      (hash-table-set! table name library)))))
 
     (define (get-names)
       (hash-table-keys table))
@@ -75,6 +77,8 @@ USA.
   (make-library-db 'host))
 
 (define (make-library name . keylist)
+  (if name
+      (guarantee library-name? name 'make-library))
   (let ((alist
 	 (cons* 'library
 		(cons 'name name)
@@ -93,7 +97,7 @@ USA.
 	    (cdr p)
 	    (let ((auto (automatic-property key)))
 	      (if (not auto)
-		  (error "Unknown library property:" key))
+		  (error "Unknown property:" key))
 	      (if (not (auto-runnable? auto this))
 		  (error "Auto property not ready:" auto))
 	      (let ((value (run-auto auto this)))
@@ -102,11 +106,11 @@ USA.
 
     (define (put! key value)
       (if (automatic-property? key)
-	  (error "Can't overwrite automatic property:" key))
+	  (warn "Overwriting automatic property:" key))
       (let ((p (assq key (cdr alist))))
 	(if p
 	    (begin
-	      (warn "Overwriting library property:" key name)
+	      (warn "Overwriting property:" key)
 	      (set-cdr! p value))
 	    (set-cdr! alist (cons (cons key value) (cdr alist))))))
 
@@ -122,7 +126,9 @@ USA.
       (set-cdr! alist (del-assq! key (cdr alist))))
 
     (define (summarize-self)
-      (list name))
+      (if name
+	  (list name)
+	  '()))
 
     (define (describe-self)
       (map (lambda (p)
@@ -282,11 +288,13 @@ USA.
   (lambda (library)
     (library 'get key)))
 
+(define library-contents (library-accessor 'contents))
 (define library-environment (library-accessor 'environment))
 (define library-exporter (library-accessor 'exporter))
 (define library-exports (library-accessor 'exports))
 (define library-filename (library-accessor 'filename))
 (define library-imports (library-accessor 'imports))
+(define library-imports-environment (library-accessor 'imports-environment))
 (define library-name (library-accessor 'name))
 (define library-parsed-contents (library-accessor 'parsed-contents))
 (define library-parsed-imports (library-accessor 'parsed-imports))
diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index d28a7e83e..19413bdd0 100644
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -41,13 +41,12 @@ USA.
 		(exports ,(map library-export->list exports))))
      (make-scode-quotation contents))))
 
-(define-automatic-property 'evaluable-contents
-    '(parsed-contents imports exports db)
+(define-automatic-property 'contents
+    '(parsed-contents imports exports imports-environment)
   #f
-  (lambda (contents imports exports db)
+  (lambda (contents imports exports env)
     (receive (body bound free)
-	(syntax-library-forms (expand-contents contents)
-			      (imports->environment imports db))
+	(syntax-library-forms (expand-contents contents) env)
       (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:"
@@ -117,14 +116,15 @@ USA.
 	      imports)
     env))
 
-(define-automatic-property 'environment '(imports evaluable-contents db)
-  (lambda (imports contents db)
-    (declare (ignore contents))
-    (import-environments-available? imports db))
-  (lambda (imports contents db)
-    (let ((env (make-environment-from-imports imports db)))
-      (scode-eval contents env)
-      env)))
+(define-automatic-property 'imports-environment '(imports db)
+  import-environments-available?
+  make-environment-from-imports)
+
+(define-automatic-property 'environment '(imports-environment contents)
+  #f
+  (lambda (env contents)
+    (scode-eval contents env)
+    env))
 
 (define (environment . import-sets)
   (let ((parsed (map parse-import-set import-sets)))
diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm
index abe351694..6a6a7cef0 100644
--- a/src/runtime/library-parser.scm
+++ b/src/runtime/library-parser.scm
@@ -41,7 +41,7 @@ USA.
 	(define (read-libs libs)
 	  (let ((form (read port)))
 	    (cond ((eof-object? form)
-		   (done (reverse libs) '() #f))
+		   (make-r7rs-source (reverse libs) #f))
 		  ((r7rs-library? form)
 		   (read-libs
 		    (cons (parse-define-library-form form pathname)
@@ -60,19 +60,22 @@ USA.
 		(error "Can't mix libraries and imports:" form))
 	    (if (r7rs-import? form)
 		(read-imports (cons (parse-import-form form) imports) libs)
-		(done libs
-		      (append-map cdr (reverse imports))
-		      (read-body (list form))))))
+		(make-r7rs-source
+		 libs
+		 ;; A program is simply an anonymous library.
+		 (make-library #f
+			       'parsed-imports (append-map cdr
+							   (reverse imports))
+			       'exports '()
+			       'parsed-contents (read-body (list form))
+			       'filename (->namestring pathname))))))
 
 	(define (read-body forms)
 	  (let ((form (read port)))
 	    (if (eof-object? form)
-		(reverse forms)
+		`((begin ,@(reverse forms)))
 		(read-body (cons form forms)))))
 
-	(define (done libs imports body)
-	  (make-r7rs-source libs imports body (->namestring pathname)))
-
 	(read-libs '())))))
 
 (define (r7rs-library? object)
@@ -84,17 +87,17 @@ USA.
        (eq? 'import (car object))))
 
 (define-record-type <r7rs-source>
-    (make-r7rs-source parsed-libraries imports body filename)
+    (make-r7rs-source libraries program)
     r7rs-source?
-  (parsed-libraries r7rs-source-parsed-libraries)
-  (imports r7rs-source-imports)
-  (body r7rs-source-body)
-  (filename r7rs-source-filename))
-
-(define-print-method r7rs-source?
-  (standard-print-method 'r7rs-source
-    (lambda (source)
-      (list (r7rs-source-filename source)))))
+  (libraries r7rs-source-libraries)
+  (program r7rs-source-program))
+
+(define (register-r7rs-source! source db)
+  (register-libraries! (r7rs-source-libraries source) db)
+  (let ((program (r7rs-source-program source)))
+    (if program
+	(register-library! program db))
+    program))
 
 (define (parse-define-library-form form #!optional pathname)
   (let ((directory
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8b541309a..16bc6ec0c 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5839,6 +5839,7 @@ USA.
   (export (runtime library)
 	  define-automatic-property
 	  host-library-db
+	  library-contents
 	  library-db?
 	  library-environment
 	  library-exporter
@@ -5857,6 +5858,7 @@ USA.
 	  library-import=?
 	  library-import?
 	  library-imports
+	  library-imports-environment
 	  library-name
 	  library-parsed-contents
 	  library-parsed-imports
@@ -5884,14 +5886,11 @@ USA.
 	  parse-define-library-form
 	  parse-import-form
 	  parse-import-set
-	  r7rs-source-body
-	  r7rs-source-filename
-	  r7rs-source-imports
-	  r7rs-source-parsed-libraries
+	  r7rs-source-program
+	  r7rs-source-libraries
 	  r7rs-source?
-	  read-r7rs-source)
-  (export (runtime load)
-	  read-r7rs-source))
+	  read-r7rs-source
+	  register-r7rs-source!))
 
 (define-package (runtime library standard)
   (files "library-standard")
diff --git a/tests/check.scm b/tests/check.scm
index ed766d51f..4bc61a656 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -66,6 +66,7 @@ USA.
     ("runtime/test-library-parser" (runtime library))
     ("runtime/test-library-standard" (runtime library))
     ("runtime/test-library-imports" (runtime library))
+    ("runtime/test-library-loader" (runtime library))
     "runtime/test-md5"
     "runtime/test-mime-codec"
     ("runtime/test-parametric-predicate" (runtime parametric-predicate))
diff --git a/tests/runtime/test-library-data/support-code.scm b/tests/runtime/test-library-data/support-code.scm
index d0db663fe..c647bafb1 100644
--- a/tests/runtime/test-library-data/support-code.scm
+++ b/tests/runtime/test-library-data/support-code.scm
@@ -116,8 +116,7 @@ USA.
      ,@ex1-contents))
 
 (define (read-dependencies)
-  (r7rs-source-parsed-libraries
-   (read-r7rs-source dependencies-filename)))
+  (r7rs-source-libraries (read-r7rs-source dependencies-filename)))
 
 (define dependencies-filename
   (->namestring
diff --git a/tests/runtime/test-library-loader.scm b/tests/runtime/test-library-loader.scm
new file mode 100644
index 000000000..19a285a4c
--- /dev/null
+++ b/tests/runtime/test-library-loader.scm
@@ -0,0 +1,52 @@
+#| -*-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.
+
+|#
+
+;;;; Tests for library loader
+
+(declare (usual-integrations))
+
+(include "test-library-data/support-code.scm")
+
+(define-test 'read-r7rs-source:r7rs-example
+  (lambda ()
+    (let ((source (read-r7rs-source r7rs-example-filename))
+	  (db (make-library-db 'test)))
+      (add-standard-libraries! db)
+      (let ((program (register-r7rs-source! source db)))
+	(assert-equal (unsyntax (library-contents program))
+		      '(begin
+			 (define grid (make-grid 24 24))
+			 (grid-set! grid 1 1 #t)
+			 (grid-set! grid 2 2 #t)
+			 (grid-set! grid 3 0 #t)
+			 (grid-set! grid 3 1 #t)
+			 (grid-set! grid 3 2 #t)
+			 (life grid 80)))
+	(let ((env (library-imports-environment program)))
+	  (assert-lset= eq?
+			(environment-bound-names env)
+			(map library-import-to
+			     (library-imports program))))))))
\ No newline at end of file
diff --git a/tests/runtime/test-library-parser.scm b/tests/runtime/test-library-parser.scm
index 6b94af3ff..3f7d5b94e 100644
--- a/tests/runtime/test-library-parser.scm
+++ b/tests/runtime/test-library-parser.scm
@@ -82,7 +82,7 @@ USA.
 (define-test 'read-r7rs-source:dependencies
   (lambda ()
     (let ((source (read-r7rs-source dependencies-filename)))
-      (let ((libraries (r7rs-source-parsed-libraries source)))
+      (let ((libraries (r7rs-source-libraries source)))
 	(assert-true (list? libraries))
 	(assert-= (length libraries) 4)
 	(assert-list= equal?
@@ -91,33 +91,32 @@ USA.
 			(foo bletch)
 			(foo grumble)
 			(foo quux))))
-      (assert-null (r7rs-source-imports source))
-      (assert-false (r7rs-source-body source))
-      (assert-string= (r7rs-source-filename source)
-		      dependencies-filename))))
+      (assert-false (r7rs-source-program source)))))
 
 (define-test 'read-r7rs-source:r7rs-example
   (lambda ()
     (let ((source (read-r7rs-source r7rs-example-filename)))
-      (let ((libraries (r7rs-source-parsed-libraries source)))
+      (let ((libraries (r7rs-source-libraries source)))
 	(assert-true (list? libraries))
 	(assert-= (length libraries) 2)
 	(assert-list= equal?
 		      (map library-name libraries)
 		      '((example grid)
 			(example life))))
-      (assert-equal (r7rs-source-imports source)
-		    '((library (scheme base))
-		      (only (library (example life)) life)
-		      (rename (prefix (library (example grid)) grid-)
-			      (grid-make . make-grid))))
-      (assert-equal (r7rs-source-body source)
-		    '((define grid (make-grid 24 24))
-		      (grid-set! grid 1 1 #t)
-		      (grid-set! grid 2 2 #t)
-		      (grid-set! grid 3 0 #t)
-		      (grid-set! grid 3 1 #t)
-		      (grid-set! grid 3 2 #t)
-		      (life grid 80)))
-      (assert-string= (r7rs-source-filename source)
-		      r7rs-example-filename))))
\ No newline at end of file
+      (let ((program (r7rs-source-program source)))
+	(assert-equal (library-parsed-imports program)
+		      '((library (scheme base))
+			(only (library (example life)) life)
+			(rename (prefix (library (example grid)) grid-)
+				(grid-make . make-grid))))
+	(assert-equal (library-parsed-contents program)
+		      '((begin
+			  (define grid (make-grid 24 24))
+			  (grid-set! grid 1 1 #t)
+			  (grid-set! grid 2 2 #t)
+			  (grid-set! grid 3 0 #t)
+			  (grid-set! grid 3 1 #t)
+			  (grid-set! grid 3 2 #t)
+			  (life grid 80))))
+	(assert-string= (library-filename program)
+			r7rs-example-filename)))))
\ No newline at end of file