Make better abstraction for scode-library files.

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index d6a8f4a63242e934d76e3fb95e92caace06041df..ec3dbc3ddfe3d704fb7ccf4966476d9c97df95b9 100644 (file)
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -321,6 +321,7 @@ USA.
 (define library-bound-names (library-accessor 'bound-names))
 (define library-contents (library-accessor 'contents))
 (define library-environment (library-accessor 'environment))
+(define library-eval-result (library-accessor 'eval-result))
 (define library-exporter (library-accessor 'exporter))
 (define library-exports (library-accessor 'exports))
 (define library-filename (library-accessor 'filename))

diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index 05345fc14547ffec4a52b00b03dc4d49396872e3..11e83f335fdbe043e653452858bd7801caed7250 100644 (file)
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -31,24 +31,6 @@ USA.
 \f
 ;;;; Syntax
 
-(define-automatic-property 'scode
-  '(name imports-used exports bound-names contents)
-  #f
-  (lambda (name imports exports bound-names contents)
-    (make-scode-declaration
-     `((target-metadata
-       (library (name ,name)
-                (imports ,@(map library-import->list imports))
-                (exports ,@(map library-export->list exports))
-                (bound-names ,@bound-names))))
-     (make-scode-quotation contents))))
-
-(define (eval-r7rs-source source db)
-  (let ((program (register-r7rs-source! source db)))
-    (if program
-       (scode-eval (library-contents program)
-                   (library-environment program)))))
-
 (define-automatic-property '(contents bound-names imports-used)
     '(parsed-contents imports exports imports-environment)
   #f
@@ -132,12 +114,6 @@ USA.
   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)))
     (let ((unusable (remove parsed-import-expandable? parsed)))
@@ -146,6 +122,132 @@ USA.
     (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))
+\f
+;;;; Evaluation
+
+(define (eval-r7rs-source source db)
+  (let ((program (register-r7rs-source! source db)))
+    (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)))
+          (map (lambda (library)
+                 (scode-library->library library filename))
+               (r7rs-scode-file-libraries scode)))))
+    (register-libraries! libraries db)
+    (for-each library-eval-result libraries)))
+
+(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)
+  #f
+  (lambda (contents env)
+    (values (scode-eval contents env)
+           env)))
 
 (define-automatic-property 'exporter '(exports environment)
   #f

diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index 15783e4e1729994fb557afc93e9c551825e59863..73bdd8eeae32ab056d48ed4ee8a5a33c54553ac1 100644 (file)
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -76,18 +76,17 @@ USA.
 ;; corresponding global identifier.  For now this is greatly simplified by
 ;; knowing that all standard libraries use global variables, but this will need
 ;; to be adapted when there are libraries that don't.
-(define (standard-library-globals import-lists)
-  (filter-map (lambda (import-list)
-               (let ((import (list->library-import import-list)))
-                 (let ((p
-                        (assoc (library-import-from-library import)
-                               standard-libraries)))
-                   (and p
-                        (memq (library-import-from import)
-                              (cdr p))
-                        (cons (library-import-to import)
-                              (library-import-from import))))))
-             import-lists))
+(define (standard-library-globals imports)
+  (filter-map (lambda (import)
+               (let ((p
+                      (assoc (library-import-from-library import)
+                             standard-libraries)))
+                 (and p
+                      (memq (library-import-from import)
+                            (cdr p))
+                      (cons (library-import-to import)
+                            (library-import-from import)))))
+             imports))
 
 (define (define-standard-library name exports)
   (let ((p (assoc name standard-libraries)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8635dda398fc24eff7b7904c7748bd884875cda9..89d1dcb620a5f3061bdf355927cf70dafc2877e8 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5839,27 +5839,28 @@ USA.
   (parent (runtime library))
   (export (runtime)
          copy-library-db
+         library-export-from
+         library-export-to
+         library-export=?
+         library-export?
+         library-import-from
+         library-import-from-library
+         library-import-to
+         library-import=?
+         library-import?
          library-scode)
   (export (runtime library)
          define-automatic-property
          library-contents
          library-db?
          library-environment
+         library-eval-result
          library-exporter
          library-export->list
-         library-export-from
-         library-export-to
-         library-export=?
-         library-export?
          library-exports
          library-filename
          library-imports-from
          library-import->list
-         library-import-from
-         library-import-from-library
-         library-import-to
-         library-import=?
-         library-import?
          library-imports
          library-imports-environment
          library-name
@@ -5924,4 +5925,14 @@ USA.
          environment                   ;R7RS
          )
   (export (runtime)
-         eval-r7rs-source))
\ No newline at end of file
+         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

diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm
index 7a74c8cabe2105022b2ac172a6764c66087812eb..037023ae124e43558faee7400cb8238f8f2d3276 100644 (file)
--- a/src/runtime/scode.scm
+++ b/src/runtime/scode.scm
@@ -130,6 +130,17 @@ USA.
   (object-type? (ucode-type comment) object))
 (register-predicate! scode-comment? 'scode-comment)
 
+(define-print-method scode-comment?
+  (standard-print-method
+      (lambda (comment)
+       (cond ((scode-library? comment) 'scode-library)
+             ((scode-declaration? comment) 'scode-declaration)
+             (else 'scode-comment)))
+    (lambda (comment)
+      (if (scode-library? comment)
+         (list (scode-library-name comment))
+         '()))))
+
 (define (scode-comment-text comment)
   (guarantee scode-comment? comment 'scode-comment-text)
   (system-pair-cdr comment))

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index 67a03bbf417b4ac04343714e58e4bd676436ff0b..22369d1a6daf849daf57c7b4dddcde323ecdb47b 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -42,12 +42,17 @@ USA.
   (import (runtime)
          copy-library-db
          current-load-library-db
+         library-import-to
          library-scode
+         make-scode-library
          r7rs-source-libraries
          r7rs-source-program
          r7rs-source?
          read-r7rs-source
          register-r7rs-source!
+         scode-library-contents
+         scode-library-imports
+         scode-library-metadata
          standard-library-globals)
   (import (runtime microcode-tables)
          microcode-type/code->name))

diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index 19de6eec75165b4a64e687fcfa52d818be671698..3be266a2a59c2bb3e2605ca1309c41309be04f13 100644 (file)
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -307,18 +307,15 @@ USA.
          '()))
 
 (define (integrate/r7rs-library library)
-  (let ((text (scode-declaration-text library))
-       (expr (scode-declaration-expression library)))
-    (make-scode-declaration
-     text
-     (make-scode-quotation
-      (receive (optimized externs-block externs)
-         (integrate/kernel-1
-          (lambda ()
-            (phase:transform-r7rs (cdr (assq 'imports (cdar (cdar text))))
-                                  (scode-quotation-expression expr))))
-       (declare (ignore externs-block externs))
-       optimized)))))
+  (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)))
 
 (define (phase:transform-r7rs imports scode)
   (in-phase "Transform"

diff --git a/src/sf/xform.scm b/src/sf/xform.scm
index a57a7a20d203c41334ebe1abdab4c2c3356f56db..e3c88c70d7de108908c57177e65154d2c5480661 100644 (file)
--- a/src/sf/xform.scm
+++ b/src/sf/xform.scm
@@ -43,16 +43,13 @@ USA.
 (define (transform/r7rs-library imports expression)
   (let ((block (block/make #f #f '())))
     (for-each (lambda (import)
-               (variable/make&bind! block
-                                    (if (pair? (cddr import))
-                                        (caddr import)
-                                        (cadr import))))
+               (variable/make&bind! block (library-import-to import)))
              imports)
     (set-block/declarations! block (r7rs-usual-integrations block imports))
     (values block
            (transform/top-level-1 'r7rs
                                   block
-                                  (block/make block #t '())
+                                  (block/make block #f '())
                                   expression))))
 
 (define top-level?)