Split library scode to a package; raise abstraction level.

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index ec3dbc3ddfe3d704fb7ccf4966476d9c97df95b9..bfee0c2673b8e343c24143eb62afac7b893985f8 100644 (file)
--- 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 c9fdb4d3ff599801b27e50b568d668a711c19b91..a7fd1528c02d93e14d7141f2f5ae0234307716e6 100644 (file)
--- a/src/runtime/library-imports.scm
+++ b/src/runtime/library-imports.scm
@@ -29,11 +29,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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 a3f1ff743e8bb2f05a444a7d01bebb89886e1c05..bb1815a7573ebd1e5983eef987fd8b172128b7e5 100644 (file)
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -31,6 +31,16 @@ USA.
 \f
 ;;;; 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))
 \f
-(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)))
-\f
-;;;; 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))))
 \f
 ;;;; 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 (file)
index 0000000..0d1ad36
--- /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))
+\f
+(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))
+\f
+(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 59da5d0fc32bfe4aa72b4403ef77ad4af7b5c549..39c2f806a1aa72a3fc4a3c9af6ec0841ffd64edf 100644 (file)
--- 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 22369d1a6daf849daf57c7b4dddcde323ecdb47b..49824ff1a6d63bf994bafdf47b26ec3f010ef97b 100644 (file)
--- 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 3be266a2a59c2bb3e2605ca1309c41309be04f13..e8b84f0fd58e8c366419381a53ca7360f8ea1f8c 100644 (file)
--- 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)))))
 \f
-(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"