From 0c10f852c01c9a48aece4e8f3ebfc49f111ee0fc Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Oct 2018 22:56:24 -0700
Subject: [PATCH] Split library scode to a package; raise abstraction level.

---
 src/runtime/library-database.scm |   1 -
 src/runtime/library-imports.scm  |  10 +-
 src/runtime/library-loader.scm   | 159 +++++++------------------------
 src/runtime/library-scode.scm    | 139 +++++++++++++++++++++++++++
 src/runtime/runtime.pkg          |  33 ++++---
 src/sf/sf.pkg                    |  14 +--
 src/sf/toplev.scm                |  35 +++----
 7 files changed, 214 insertions(+), 177 deletions(-)
 create mode 100644 src/runtime/library-scode.scm

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index ec3dbc3dd..bfee0c267 100644
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -331,5 +331,4 @@ USA.
 (define library-name (library-accessor 'name))
 (define library-parsed-contents (library-accessor 'parsed-contents))
 (define library-parsed-imports (library-accessor 'parsed-imports))
-(define library-scode (library-accessor 'scode))
 (define library-syntaxed-contents (library-accessor 'syntaxed-contents))
\ No newline at end of file
diff --git a/src/runtime/library-imports.scm b/src/runtime/library-imports.scm
index c9fdb4d3f..a7fd1528c 100644
--- a/src/runtime/library-imports.scm
+++ b/src/runtime/library-imports.scm
@@ -29,11 +29,6 @@ USA.
 
 (declare (usual-integrations))
 
-(define (parsed-imports-expandable? imports db)
-  (every (lambda (import)
-	   (parsed-import-expandable? import db))
-	 imports))
-
 (define (parsed-import-expandable? import db)
   (let ((name (parsed-import-library import)))
     (and (registered-library? name db)
@@ -53,7 +48,10 @@ USA.
     (reduce-right append! '() converted-sets)))
 
 (define-automatic-property 'imports '(parsed-imports db)
-  parsed-imports-expandable?
+  (lambda (imports db)
+    (every (lambda (import)
+	     (parsed-import-expandable? import db))
+	   imports))
   expand-parsed-imports)
 
 (define (find-intersections converted-sets)
diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index a3f1ff743..bb1815a75 100644
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -31,6 +31,16 @@ USA.
 
 ;;;; Syntax
 
+(define (syntax-r7rs-source source db)
+  (register-r7rs-source! source (copy-library-db db))
+  (make-r7rs-scode-file
+   (map library->scode-library
+	(append (r7rs-source-libraries source)
+		(let ((program (r7rs-source-program source)))
+		  (if program
+		      (list program)
+		      '()))))))
+
 (define-automatic-property '(contents bound-names imports-used)
     '(parsed-contents imports exports imports-environment)
   #f
@@ -70,17 +80,7 @@ USA.
 		   (error "Unknown content directive:" directive))))
 	      contents))
 
-(define (imports->environment imports db)
-  (if (not (import-environments-available? imports db))
-      (error "Imported libraries unavailable:"
-	     (library-imports-from
-	      (remove import-environment-available? imports))))
-  (make-environment-from-imports imports db))
-
-(define (import-environments-available? imports db)
-  (every (lambda (import)
-	   (import-environment-available? import db))
-	 imports))
+;;;; Imports environment
 
 (define (import-environment-available? import db)
   (let ((name (library-import-from-library import)))
@@ -111,95 +111,27 @@ USA.
     env))
 
 (define-automatic-property 'imports-environment '(imports db)
-  import-environments-available?
+  (lambda (imports db)
+    (every (lambda (import)
+	     (import-environment-available? import db))
+	   imports))
   make-environment-from-imports)
 
 (define (environment . import-sets)
-  (let ((parsed (map parse-import-set import-sets)))
+  (let ((parsed (map parse-import-set import-sets))
+	(db host-library-db))
     (let ((unusable (remove parsed-import-expandable? parsed)))
       (if (pair? unusable)
 	  (error "Imports not usable:" unusable)))
-    (imports->environment
-     (expand-parsed-imports parsed host-library-db)
-     host-library-db)))
-
-;;;; SCode representation
-
-(define-automatic-property 'scode
-  '(name imports-used exports bound-names contents)
-  #f
-  (lambda (name imports exports bound-names contents)
-    (make-scode-library (make-scode-library-metadata name imports exports
-						     bound-names)
-			contents)))
-
-(define (make-scode-library metadata contents)
-  (make-scode-declaration `((target-metadata ,metadata))
-			  (make-scode-quotation contents)))
-
-(define (scode-library? object)
-  (and (scode-declaration? object)
-       (let ((text (scode-declaration-text object)))
-	 (and (singleton-list? text)
-	      (target-metadata? (car text))
-	      (let ((metadata-values (metadata-elt-values (car text))))
-		(and (singleton-list? metadata-values)
-		     (scode-library-metadata? (car metadata-values))))))
-       (scode-quotation? (scode-declaration-expression object))))
-
-(define (scode-library-metadata library)
-  (car (metadata-elt-values (car (scode-declaration-text library)))))
-
-(define (scode-library-contents library)
-  (scode-quotation-expression (scode-declaration-expression library)))
-
-(define (make-scode-library-metadata name imports exports bound-names)
-  `(scode-library (name ,name)
-		  (imports ,@(map library-import->list imports))
-		  (exports ,@(map library-export->list exports))
-		  (bound-names ,@bound-names)))
-
-(define (scode-library-property keyword library)
-  (metadata-elt-values
-   (find (lambda (metadata)
-	   (eq? (metadata-elt-keyword metadata) keyword))
-	 (metadata-elt-values (scode-library-metadata library)))))
-
-(define (scode-library-name library)
-  (car (scode-library-property 'name library)))
-
-(define (scode-library-imports library)
-  (map list->library-import (scode-library-property 'imports library)))
-
-(define (scode-library-exports library)
-  (map list->library-export (scode-library-property 'exports library)))
-
-(define (singleton-list? object)
-  (and (pair? object)
-       (null? (cdr object))))
-
-(define (specific-metadata-predicate keyword)
-  (lambda (object)
-    (and (metadata-elt? object)
-	 (eq? (metadata-elt-keyword object) keyword)
-	 (every metadata-elt? (metadata-elt-values object)))))
-
-(define target-metadata? (specific-metadata-predicate 'target-metadata))
-(define scode-library-metadata? (specific-metadata-predicate 'scode-library))
-
-(define (metadata-elt? object)
-  (and (pair? object)
-       (symbol? (car object))
-       (list? (cdr object))))
-(register-predicate! metadata-elt? 'metadata-elt)
-
-(define (metadata-elt-keyword elt)
-  (guarantee metadata-elt? elt 'metadata-elt-keyword)
-  (car elt))
-
-(define (metadata-elt-values elt)
-  (guarantee metadata-elt? elt 'metadata-elt-values)
-  (cdr elt))
+    (let ((imports (expand-parsed-imports parsed db)))
+      (let ((unavailable
+	     (remove (lambda (import)
+		       (import-environment-available? import db))
+		     imports)))
+	(if (pair? unavailable)
+	    (error "Imported libraries unavailable:"
+		   (library-imports-from unavailable))))
+      (make-environment-from-imports imports db))))
 
 ;;;; Evaluation
 
@@ -208,24 +140,6 @@ USA.
     (if program
 	(library-eval-result program))))
 
-(define (r7rs-scode-file? scode)
-  (let ((scode (strip-comments scode)))
-    (or (scode-library? scode)
-	(and (scode-sequence? scode)
-	     (every scode-library? (scode-sequence-actions scode))))))
-
-(define (r7rs-scode-file-libraries scode)
-  (let ((scode (strip-comments scode)))
-    (if (scode-library? scode)
-	(list scode)
-	(scode-sequence-actions scode))))
-
-(define (strip-comments object)
-  (if (and (scode-comment? object)
-	   (not (scode-declaration? object)))
-      (strip-comments (scode-comment-expression object))
-      object))
-
 (define (eval-r7rs-scode-file scode pathname db)
   (let ((libraries
 	 (let ((filename (->namestring pathname)))
@@ -236,25 +150,16 @@ USA.
     (let loop ((libraries libraries) (result unspecific))
       (if (pair? libraries)
 	  (loop (cdr libraries)
-		(let* ((library (car libraries))
-		       (result* (library-eval-result library)))
-		  (or (library-name library)
-		      result*)))
+		(library-eval-result (car libraries)))
 	  result))))
 
-(define (scode-library->library library filename)
-  (make-library (scode-library-name library)
-		'imports (scode-library-imports library)
-		'exports (scode-library-exports library)
-		'contents (scode-library-contents library)
-		'filename filename))
-
 (define-automatic-property '(eval-result environment)
-    '(contents imports-environment)
+    '(contents imports-environment name)
   #f
-  (lambda (contents env)
-    (values (scode-eval contents env)
-	    env)))
+  (lambda (contents env name)
+    (let ((result (scode-eval contents env)))
+      (values (or name result)
+	      env))))
 
 (define-automatic-property 'exporter '(exports environment)
   #f
diff --git a/src/runtime/library-scode.scm b/src/runtime/library-scode.scm
new file mode 100644
index 000000000..0d1ad3666
--- /dev/null
+++ b/src/runtime/library-scode.scm
@@ -0,0 +1,139 @@
+#| -*-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: SCode representation
+;;; package: (runtime library scode)
+
+(declare (usual-integrations))
+
+(define (make-scode-library metadata contents)
+  (make-scode-declaration `((target-metadata ,metadata))
+			  (make-scode-quotation contents)))
+
+(define (scode-library? object)
+  (and (scode-declaration? object)
+       (let ((text (scode-declaration-text object)))
+	 (and (singleton-list? text)
+	      (target-metadata? (car text))
+	      (let ((metadata-values (metadata-elt-values (car text))))
+		(and (singleton-list? metadata-values)
+		     (scode-library-metadata? (car metadata-values))))))
+       (scode-quotation? (scode-declaration-expression object))))
+
+(define (scode-library-metadata library)
+  (car (metadata-elt-values (car (scode-declaration-text library)))))
+
+(define (scode-library-contents library)
+  (scode-quotation-expression (scode-declaration-expression library)))
+
+(define (map-scode-library procedure library)
+  (make-scode-library (scode-library-metadata library)
+		      (procedure (scode-library-contents library))))
+
+(define (scode-library-property keyword library)
+  (metadata-elt-values
+   (find (lambda (metadata)
+	   (eq? (metadata-elt-keyword metadata) keyword))
+	 (metadata-elt-values (scode-library-metadata library)))))
+
+(define (scode-library-name library)
+  (car (scode-library-property 'name library)))
+
+(define (scode-library-imports library)
+  (map list->library-import (scode-library-property 'imports library)))
+
+(define (scode-library-exports library)
+  (map list->library-export (scode-library-property 'exports library)))
+
+(define (singleton-list? object)
+  (and (pair? object)
+       (null? (cdr object))))
+
+(define (specific-metadata-predicate keyword)
+  (lambda (object)
+    (and (metadata-elt? object)
+	 (eq? (metadata-elt-keyword object) keyword)
+	 (every metadata-elt? (metadata-elt-values object)))))
+
+(define target-metadata? (specific-metadata-predicate 'target-metadata))
+(define scode-library-metadata? (specific-metadata-predicate 'scode-library))
+
+(define (metadata-elt? object)
+  (and (pair? object)
+       (symbol? (car object))
+       (list? (cdr object))))
+(register-predicate! metadata-elt? 'metadata-elt)
+
+(define (metadata-elt-keyword elt)
+  (guarantee metadata-elt? elt 'metadata-elt-keyword)
+  (car elt))
+
+(define (metadata-elt-values elt)
+  (guarantee metadata-elt? elt 'metadata-elt-values)
+  (cdr elt))
+
+(define (library->scode-library library)
+  (make-scode-library
+   `(scode-library
+     (name ,(library-name library))
+     (imports ,@(map library-import->list (library-imports-used library)))
+     (exports ,@(map library-export->list (library-exports library))))
+   (library-contents library)))
+
+(define (scode-library->library library filename)
+  (guarantee scode-library? library 'scode-library->library)
+  (make-library (scode-library-name library)
+		'imports (scode-library-imports library)
+		'exports (scode-library-exports library)
+		'contents (scode-library-contents library)
+		'filename filename))
+
+(define (make-r7rs-scode-file libraries)
+  (guarantee-list-of scode-library? libraries 'make-r7rs-scode-file)
+  (make-scode-sequence libraries))
+
+(define (r7rs-scode-file? scode)
+  (let ((scode (strip-comments scode)))
+    (or (scode-library? scode)
+	(and (scode-sequence? scode)
+	     (every scode-library? (scode-sequence-actions scode))))))
+(register-predicate! r7rs-scode-file? 'r7rs-scode-file)
+
+(define (r7rs-scode-file-libraries scode)
+  (let ((scode (strip-comments scode)))
+    (if (scode-library? scode)
+	(list scode)
+	(scode-sequence-actions scode))))
+
+(define (strip-comments object)
+  (if (and (scode-comment? object)
+	   (not (scode-declaration? object)))
+      (strip-comments (scode-comment-expression object))
+      object))
+
+(define (map-r7rs-scode-file procedure scode)
+  (guarantee r7rs-scode-file? scode 'map-r7rs-scode-file)
+  (make-scode-sequence (map procedure (r7rs-scode-file-libraries scode))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 59da5d0fc..39c2f806a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5848,8 +5848,7 @@ USA.
 	  library-import-from-library
 	  library-import-to
 	  library-import=?
-	  library-import?
-	  library-scode)
+	  library-import?)
   (export (runtime library)
 	  define-automatic-property
 	  library-contents
@@ -5861,6 +5860,7 @@ USA.
 	  library-exports
 	  library-filename
 	  library-imports-from
+	  library-imports-used
 	  library-import->list
 	  library-imports
 	  library-imports-environment
@@ -5916,8 +5916,23 @@ USA.
   (parent (runtime library))
   (export (runtime library)
 	  expand-parsed-imports
-	  parsed-import-expandable?
-	  parsed-imports-expandable?))
+	  parsed-import-expandable?))
+
+(define-package (runtime library scode)
+  (files "library-scode")
+  (parent (runtime library))
+  (export (runtime)
+	  map-r7rs-scode-file
+	  map-scode-library
+	  r7rs-scode-file?
+	  scode-library-imports
+	  scode-library-name
+	  scode-library?)
+  (export (runtime library)
+	  library->scode-library
+	  make-r7rs-scode-file
+	  r7rs-scode-file-libraries
+	  scode-library->library))
 
 (define-package (runtime library loader)
   (files "library-loader")
@@ -5928,12 +5943,4 @@ USA.
   (export (runtime)
 	  eval-r7rs-scode-file
 	  eval-r7rs-source
-	  make-scode-library
-	  r7rs-scode-file-libraries
-	  r7rs-scode-file?
-	  scode-library-contents
-	  scode-library-exports
-	  scode-library-imports
-	  scode-library-metadata
-	  scode-library-name
-	  scode-library?))
\ No newline at end of file
+	  syntax-r7rs-source))
\ No newline at end of file
diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index 22369d1a6..49824ff1a 100644
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -40,20 +40,16 @@ USA.
           sf:enable-argument-deletion?
           sf:enable-constant-folding?)
   (import (runtime)
-	  copy-library-db
 	  current-load-library-db
 	  library-import-to
-	  library-scode
-	  make-scode-library
-	  r7rs-source-libraries
-	  r7rs-source-program
+	  map-r7rs-scode-file
+	  map-scode-library
+	  r7rs-scode-file?
 	  r7rs-source?
 	  read-r7rs-source
-	  register-r7rs-source!
-	  scode-library-contents
 	  scode-library-imports
-	  scode-library-metadata
-	  standard-library-globals)
+	  standard-library-globals
+	  syntax-r7rs-source)
   (import (runtime microcode-tables)
 	  microcode-type/code->name))
 
diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index 3be266a2a..e8b84f0fd 100644
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -246,8 +246,8 @@ USA.
 
 (define (integrate/kernel get-scode)
   (let ((scode (get-scode)))
-    (if (list? scode)
-	(integrate/r7rs-libraries scode)
+    (if (r7rs-scode-file? scode)
+	(integrate/r7rs-scode-file scode)
 	(integrate/kernel-1 (lambda () (phase:transform (get-scode)))))))
 
 (define (integrate/kernel-1 get-transformed)
@@ -267,14 +267,7 @@ USA.
   (in-phase "Syntax"
     (lambda ()
       (if (r7rs-source? s-expressions)
-	  (let ((db (copy-library-db (current-load-library-db))))
-	    (register-r7rs-source! s-expressions db)
-	    (map library-scode
-		 (append (r7rs-source-libraries s-expressions)
-			 (let ((program (r7rs-source-program s-expressions)))
-			   (if program
-			       (list program)
-			       '())))))
+	  (syntax-r7rs-source s-expressions (current-load-library-db))
 	  (syntax* (if (null? declarations)
 		       s-expressions
 		       (cons (cons (close-syntax 'declare
@@ -301,21 +294,21 @@ USA.
 	  (operations->external operations environment)
 	(values (cgen/external expression) externs-block externs)))))
 
-(define (integrate/r7rs-libraries libraries)
-  (values (make-scode-sequence (map integrate/r7rs-library libraries))
+(define (integrate/r7rs-scode-file scode)
+  (values (map-r7rs-scode-file integrate/r7rs-library scode)
 	  #f
 	  '()))
 
 (define (integrate/r7rs-library library)
-  (make-scode-library
-   (scode-library-metadata library)
-   (receive (optimized externs-block externs)
-       (integrate/kernel-1
-	(lambda ()
-	  (phase:transform-r7rs (scode-library-imports library)
-				(scode-library-contents library))))
-     (declare (ignore externs-block externs))
-     optimized)))
+  (let ((imports (scode-library-imports library)))
+    (map-scode-library (lambda (contents)
+			 (receive (optimized externs-block externs)
+			     (integrate/kernel-1
+			      (lambda ()
+				(phase:transform-r7rs imports contents)))
+			   (declare (ignore externs-block externs))
+			   optimized))
+		       library)))
 
 (define (phase:transform-r7rs imports scode)
   (in-phase "Transform"
-- 
2.25.1