From: Chris Hanson Date: Sun, 7 Oct 2018 20:27:04 +0000 (-0700) Subject: Get SF working on R7RS files. Loader needs to be modified to load them. X-Git-Tag: mit-scheme-pucked-9.2.19~2^2~11 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7874f42dc3b304475d695d6ff89238d4bbc0a674;p=mit-scheme.git Get SF working on R7RS files. Loader needs to be modified to load them. --- diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 48e8eec71..d6a8f4a63 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -30,7 +30,7 @@ USA. (declare (usual-integrations)) (define (make-library-db name) - (let ((table (make-equal-hash-table))) + (let loop ((table (make-equal-hash-table))) (define (has? name) (hash-table-exists? table name)) @@ -56,6 +56,9 @@ USA. (define (get-all) (hash-table-values table)) + (define (get-copy) + (loop (hash-table-copy table))) + (define (summarize-self) (list name)) @@ -66,12 +69,16 @@ USA. (define this (bundle library-db? - has? get put! get-names get-all + has? get put! get-names get-all get-copy summarize-self describe-self)) this)) (define library-db? (make-bundle-predicate 'library-database)) + +(define (copy-library-db db) + (guarantee library-db? db 'copy-library-db) + (db 'get-copy)) (define (make-library name . keylist) (if name @@ -236,14 +243,14 @@ USA. (library-import-to e2)))) (define (library-import->list import) - (list (library-import-from-library import) - (library-import-from import) - (library-import-to import))) + (cons* (library-import-from-library import) + (library-import-from import) + (if (eq? (library-import-from import) (library-import-to import)) + '() + (list (library-import-to import))))) (define (list->library-import list) - (make-library-import (car list) - (cadr list) - (caddr list))) + (apply make-library-import list)) (define (library-imports-from imports) (delete-duplicates (map library-import-from-library imports) @@ -274,11 +281,13 @@ USA. (library-export-to e2)))) (define (library-export->list export) - (list (library-export-from export) - (library-export-to export))) + (cons (library-export-from export) + (if (eq? (library-export-from export) (library-export-to export)) + '() + (list (library-export-to export))))) (define (list->library-export list) - (make-library-export (car list) (cadr list))) + (apply make-library-export list)) (define-print-method library-export? (standard-print-method 'library-export @@ -309,6 +318,7 @@ USA. (lambda (library) (library 'get key))) +(define library-bound-names (library-accessor 'bound-names)) (define library-contents (library-accessor 'contents)) (define library-environment (library-accessor 'environment)) (define library-exporter (library-accessor 'exporter)) @@ -316,7 +326,9 @@ USA. (define library-filename (library-accessor 'filename)) (define library-imports (library-accessor 'imports)) (define library-imports-environment (library-accessor 'imports-environment)) +(define library-imports-used (library-accessor 'imports-used)) (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-loader.scm b/src/runtime/library-loader.scm index 69b7dd733..05345fc14 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -31,14 +31,16 @@ USA. ;;;; Syntax -(define-automatic-property 'scode '(name imports exports contents) +(define-automatic-property 'scode + '(name imports-used exports bound-names contents) #f - (lambda (name imports exports contents) + (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)))) + `((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) @@ -47,7 +49,7 @@ USA. (scode-eval (library-contents program) (library-environment program))))) -(define-automatic-property 'contents +(define-automatic-property '(contents bound-names imports-used) '(parsed-contents imports exports imports-environment) #f (lambda (contents imports exports env) @@ -63,7 +65,11 @@ USA. (if (not (lset<= eq? free imports-to)) (warn "Library has free references not provided by imports:" (lset-difference eq? free imports-to)))) - body))) + (values body + bound + (filter (lambda (import) + (memq (library-import-to import) free)) + imports))))) (define (expand-contents contents) (append-map (lambda (directive) diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index 976fb08a6..15783e4e1 100644 --- a/src/runtime/library-standard.scm +++ b/src/runtime/library-standard.scm @@ -71,6 +71,24 @@ USA. (define (standard-library-exports name) (cdr (assoc name standard-libraries))) +;; Filters the given imports to find those that are equivalent to global +;; variables, and for each one returns a pair of the "to" identifier and the +;; 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 (define-standard-library name exports) (let ((p (assoc name standard-libraries))) (if p diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index dee2664fc..8635dda39 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5837,6 +5837,9 @@ USA. (define-package (runtime library database) (files "library-database") (parent (runtime library)) + (export (runtime) + copy-library-db + library-scode) (export (runtime library) define-automatic-property library-contents @@ -5880,24 +5883,25 @@ USA. (files "library-parser") (parent (runtime library)) (export (runtime) - read-r7rs-source) + r7rs-source-program + r7rs-source-libraries + r7rs-source? + read-r7rs-source + register-r7rs-source!) (export (runtime library) library-name=? library-name? parsed-import-library parse-define-library-form parse-import-form - parse-import-set - r7rs-source-program - r7rs-source-libraries - r7rs-source? - register-r7rs-source!)) + parse-import-set)) (define-package (runtime library standard) (files "library-standard") (parent (runtime library)) (export (runtime) - host-library-db) + host-library-db + standard-library-globals) (export (runtime library) add-standard-libraries! check-standard-libraries! diff --git a/src/sf/pardec.scm b/src/sf/pardec.scm index 22495cfe7..3ba0a1651 100644 --- a/src/sf/pardec.scm +++ b/src/sf/pardec.scm @@ -36,7 +36,11 @@ USA. (let ((declarations (merge-usual-integrations declarations))) (make-declaration-set declarations (append-map (lambda (declaration) - (parse-declaration block declaration)) + (if (eq? (car declaration) + 'target-metadata) + '() + (parse-declaration block + declaration))) declarations)))) (define (merge-usual-integrations declarations) @@ -243,6 +247,33 @@ USA. 'global))) remaining)))) +;;; The corresponding case for R7RS is much simpler since the imports are +;;; explicit. + +(define (r7rs-usual-integrations block imports) + (make-declaration-set '() + (let ((globals (standard-library-globals imports))) + (let ((constructor + (lambda (operation) + (lambda (name value) + (let ((global + (find (lambda (global) + (eq? (cdr global) name)) + globals))) + (and global + (make-declaration operation + (block/lookup-name block + (car global) + #f) + value + 'global))))))) + (append (filter-map (constructor 'expand) + usual-integrations/expansion-names + usual-integrations/expansion-values) + (filter-map (constructor 'integrate) + usual-integrations/constant-names + usual-integrations/constant-values)))))) + (define (define-integration-declaration operation) (define-declaration operation (lambda (block names) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index 5594a814c..67a03bbf4 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -39,6 +39,16 @@ USA. (export () sf:enable-argument-deletion? sf:enable-constant-folding?) + (import (runtime) + copy-library-db + current-load-library-db + library-scode + r7rs-source-libraries + r7rs-source-program + r7rs-source? + read-r7rs-source + register-r7rs-source! + standard-library-globals) (import (runtime microcode-tables) microcode-type/code->name)) @@ -67,6 +77,7 @@ USA. (parent (scode-optimizer)) (export (scode-optimizer) transform/top-level + transform/r7rs-library transform/recursive)) (define-package (scode-optimizer integrate) @@ -116,7 +127,8 @@ USA. declarations/original declarations/parse known-declaration? - operations->external)) + operations->external + r7rs-usual-integrations)) (define-package (scode-optimizer copy) (files "copy") diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 5af70222d..cb4233a55 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -53,18 +53,17 @@ USA. (*current-block-names* '())) (call-with-values (lambda () - (let ((operations (operations/make)) + (let ((operations + (declarations/bind (operations/make) + (block/declarations block))) (environment (environment/make))) (if (open-block? expression) (integrate/open-block operations environment expression) - (let ((operations - (declarations/bind operations - (block/declarations block)))) - (values operations - environment - (integrate/expression operations - environment - expression)))))) + (values operations + environment + (integrate/expression operations + environment + expression))))) (lambda (operations environment expression) (values operations environment (quotation/make scode diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm index a95aea4e0..19de6eec7 100644 --- a/src/sf/toplev.scm +++ b/src/sf/toplev.scm @@ -152,16 +152,6 @@ USA. (with-notification message do-it))) (do-it)))))) -;; If not #F, should be a string file type. SF will pretty print -;; the macro-expanded, but unoptimized file content to the output -;; directory in a file with this extension. -(define macroexpanded-pathname-type #f) - -;; If not #F, should be a string file type. SF will pretty print -;; the optimized file content to the output directory in a file -;; with this extension. -(define optimized-pathname-type #f) - (define (sf/file->scode input-pathname output-pathname environment declarations) (fluid-let ((sf/default-externs-pathname @@ -172,23 +162,12 @@ USA. externs-pathname-type 'newest))) (receive (expression externs-block externs) - (integrate/file input-pathname - (and output-pathname - macroexpanded-pathname-type - (pathname-new-type output-pathname - macroexpanded-pathname-type)) - environment declarations) + (integrate/file input-pathname environment declarations) (if output-pathname (write-externs-file (pathname-new-type output-pathname externs-pathname-type) externs-block externs)) - (if (and output-pathname - optimized-pathname-type) - (call-with-output-file - (pathname-new-type output-pathname optimized-pathname-type) - (lambda (port) - (pp expression port)))) expression))) (define externs-pathname-type @@ -249,17 +228,12 @@ USA. ;;;; Optimizer Top Level -(define (integrate/file file-name macroexpanded-file-name environment declarations) +(define (integrate/file file-name environment declarations) (integrate/kernel (lambda () - (let ((scode (phase:syntax (phase:read file-name) - environment - declarations))) - (if macroexpanded-file-name - (call-with-output-file macroexpanded-file-name - (lambda (port) - (pp scode port)))) - scode)))) + (phase:syntax (phase:read file-name) + environment + declarations)))) (define (integrate/simple preprocessor input receiver) (call-with-values @@ -271,25 +245,44 @@ USA. expression)))) (define (integrate/kernel get-scode) - (receive (operations environment expression) - (receive (block expression) (phase:transform (get-scode)) - (phase:optimize block expression)) - (phase:generate-scode operations environment expression))) + (let ((scode (get-scode))) + (if (list? scode) + (integrate/r7rs-libraries scode) + (integrate/kernel-1 (lambda () (phase:transform (get-scode))))))) + +(define (integrate/kernel-1 get-transformed) + (call-with-values + (lambda () + (call-with-values get-transformed + phase:optimize)) + phase:generate-scode)) (define (phase:read filename) - (in-phase "Read" (lambda () (read-file filename)))) + (in-phase "Read" + (lambda () + (or (read-r7rs-source filename) + (read-file filename))))) (define (phase:syntax s-expressions environment declarations) (in-phase "Syntax" (lambda () - (syntax* (if (null? declarations) - s-expressions - (cons (cons (close-syntax 'declare - (runtime-environment->syntactic - system-global-environment)) - declarations) - s-expressions)) - environment)))) + (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* (if (null? declarations) + s-expressions + (cons (cons (close-syntax 'declare + (runtime-environment->syntactic + system-global-environment)) + declarations) + s-expressions)) + environment))))) (define (phase:transform scode) (in-phase "Transform" @@ -297,7 +290,9 @@ USA. (transform/top-level scode sf/top-level-definitions)))) (define (phase:optimize block expression) - (in-phase "Optimize" (lambda () (integrate/top-level block expression)))) + (in-phase "Optimize" + (lambda () + (integrate/top-level block expression)))) (define (phase:generate-scode operations environment expression) (in-phase "Generate SCode" @@ -305,6 +300,30 @@ USA. (receive (externs-block externs) (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)) + #f + '())) + +(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))))) + +(define (phase:transform-r7rs imports scode) + (in-phase "Transform" + (lambda () + (transform/r7rs-library imports scode)))) (define (in-phase name thunk) (if (eq? sf:noisy? 'old-style) diff --git a/src/sf/xform.scm b/src/sf/xform.scm index 5f4a440ef..a57a7a20d 100644 --- a/src/sf/xform.scm +++ b/src/sf/xform.scm @@ -40,6 +40,21 @@ USA. (define (transform/recursive block top-level-block expression) (transform/top-level-1 false top-level-block block expression)) +(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)))) + imports) + (set-block/declarations! block (r7rs-usual-integrations block imports)) + (values block + (transform/top-level-1 'r7rs + block + (block/make block #t '()) + expression)))) + (define top-level?) (define top-level-block) (define root-block) @@ -58,7 +73,8 @@ USA. (if (not top-level?) (error "Open blocks allowed only at top level:" expression)) (let ((declarations (scode-open-block-declarations expression))) - (if (not (assq 'usual-integrations declarations)) + (if (not (or (eq? tl? 'r7rs) + (assq 'usual-integrations declarations))) (ui-warning)) (transform/open-block* expression block @@ -67,7 +83,7 @@ USA. declarations (scode-open-block-actions expression)))) (transform/expression block environment expression))))) - + (define (ui-warning) (for-each (lambda (line)