From: Chris Hanson Date: Sun, 7 Oct 2018 22:16:40 +0000 (-0700) Subject: Make better abstraction for scode-library files. X-Git-Tag: mit-scheme-pucked-9.2.19~2^2~9 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ed2516418d8f4329158538c7e88c90d1d3b6da8;p=mit-scheme.git Make better abstraction for scode-library files. --- diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index d6a8f4a63..ec3dbc3dd 100644 --- 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 05345fc14..11e83f335 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -31,24 +31,6 @@ USA. ;;;; 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))) + +;;;; 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)) + +;;;; 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 15783e4e1..73bdd8eea 100644 --- 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 8635dda39..89d1dcb62 100644 --- 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 7a74c8cab..037023ae1 100644 --- 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 67a03bbf4..22369d1a6 100644 --- 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 19de6eec7..3be266a2a 100644 --- 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 a57a7a20d..e3c88c70d 100644 --- 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?)