From ee9b96914dfcf86b10af113cb11b9a4b764ecbcc Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 6 Oct 2018 16:28:42 -0700 Subject: [PATCH] Another rewrite, this time to treat programs as anonymous libraries. This change simplifies handling programs since they can now use the machinery developed for libraries. So now r7rs-source is just a combination of some libraries and an optional program. Also added property 'imports-environment to get the environment prior to evaluation. --- src/runtime/library-database.scm | 24 ++++++--- src/runtime/library-loader.scm | 26 +++++----- src/runtime/library-parser.scm | 39 +++++++------- src/runtime/runtime.pkg | 13 +++-- tests/check.scm | 1 + .../test-library-data/support-code.scm | 3 +- tests/runtime/test-library-loader.scm | 52 +++++++++++++++++++ tests/runtime/test-library-parser.scm | 41 +++++++-------- 8 files changed, 130 insertions(+), 69 deletions(-) create mode 100644 tests/runtime/test-library-loader.scm diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 241b585f8..2b43e9404 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -42,11 +42,13 @@ USA. (if (and (library 'has? 'db) (not (eq? (library 'get 'db) this))) (error "Can't use library in multiple databases:" library)) + (library 'put! 'db this) (let ((name (library 'get 'name))) - (if (has? name) - (warn "Overwriting library:" name)) - (library 'put! 'db this) - (hash-table-set! table name library))) + (if name + (begin + (if (has? name) + (warn "Overwriting library:" name)) + (hash-table-set! table name library))))) (define (get-names) (hash-table-keys table)) @@ -75,6 +77,8 @@ USA. (make-library-db 'host)) (define (make-library name . keylist) + (if name + (guarantee library-name? name 'make-library)) (let ((alist (cons* 'library (cons 'name name) @@ -93,7 +97,7 @@ USA. (cdr p) (let ((auto (automatic-property key))) (if (not auto) - (error "Unknown library property:" key)) + (error "Unknown property:" key)) (if (not (auto-runnable? auto this)) (error "Auto property not ready:" auto)) (let ((value (run-auto auto this))) @@ -102,11 +106,11 @@ USA. (define (put! key value) (if (automatic-property? key) - (error "Can't overwrite automatic property:" key)) + (warn "Overwriting automatic property:" key)) (let ((p (assq key (cdr alist)))) (if p (begin - (warn "Overwriting library property:" key name) + (warn "Overwriting property:" key) (set-cdr! p value)) (set-cdr! alist (cons (cons key value) (cdr alist)))))) @@ -122,7 +126,9 @@ USA. (set-cdr! alist (del-assq! key (cdr alist)))) (define (summarize-self) - (list name)) + (if name + (list name) + '())) (define (describe-self) (map (lambda (p) @@ -282,11 +288,13 @@ USA. (lambda (library) (library 'get key))) +(define library-contents (library-accessor 'contents)) (define library-environment (library-accessor 'environment)) (define library-exporter (library-accessor 'exporter)) (define library-exports (library-accessor 'exports)) (define library-filename (library-accessor 'filename)) (define library-imports (library-accessor 'imports)) +(define library-imports-environment (library-accessor 'imports-environment)) (define library-name (library-accessor 'name)) (define library-parsed-contents (library-accessor 'parsed-contents)) (define library-parsed-imports (library-accessor 'parsed-imports)) diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm index d28a7e83e..19413bdd0 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -41,13 +41,12 @@ USA. (exports ,(map library-export->list exports)))) (make-scode-quotation contents)))) -(define-automatic-property 'evaluable-contents - '(parsed-contents imports exports db) +(define-automatic-property 'contents + '(parsed-contents imports exports imports-environment) #f - (lambda (contents imports exports db) + (lambda (contents imports exports env) (receive (body bound free) - (syntax-library-forms (expand-contents contents) - (imports->environment imports db)) + (syntax-library-forms (expand-contents contents) env) (let ((exports-from (map library-export-from exports))) (if (not (lset<= eq? exports-from (lset-union eq? bound free))) (warn "Library export refers to unbound identifiers:" @@ -117,14 +116,15 @@ USA. imports) env)) -(define-automatic-property 'environment '(imports evaluable-contents db) - (lambda (imports contents db) - (declare (ignore contents)) - (import-environments-available? imports db)) - (lambda (imports contents db) - (let ((env (make-environment-from-imports imports db))) - (scode-eval contents env) - env))) +(define-automatic-property 'imports-environment '(imports db) + 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))) diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm index abe351694..6a6a7cef0 100644 --- a/src/runtime/library-parser.scm +++ b/src/runtime/library-parser.scm @@ -41,7 +41,7 @@ USA. (define (read-libs libs) (let ((form (read port))) (cond ((eof-object? form) - (done (reverse libs) '() #f)) + (make-r7rs-source (reverse libs) #f)) ((r7rs-library? form) (read-libs (cons (parse-define-library-form form pathname) @@ -60,19 +60,22 @@ USA. (error "Can't mix libraries and imports:" form)) (if (r7rs-import? form) (read-imports (cons (parse-import-form form) imports) libs) - (done libs - (append-map cdr (reverse imports)) - (read-body (list form)))))) + (make-r7rs-source + libs + ;; A program is simply an anonymous library. + (make-library #f + 'parsed-imports (append-map cdr + (reverse imports)) + 'exports '() + 'parsed-contents (read-body (list form)) + 'filename (->namestring pathname)))))) (define (read-body forms) (let ((form (read port))) (if (eof-object? form) - (reverse forms) + `((begin ,@(reverse forms))) (read-body (cons form forms))))) - (define (done libs imports body) - (make-r7rs-source libs imports body (->namestring pathname))) - (read-libs '()))))) (define (r7rs-library? object) @@ -84,17 +87,17 @@ USA. (eq? 'import (car object)))) (define-record-type - (make-r7rs-source parsed-libraries imports body filename) + (make-r7rs-source libraries program) r7rs-source? - (parsed-libraries r7rs-source-parsed-libraries) - (imports r7rs-source-imports) - (body r7rs-source-body) - (filename r7rs-source-filename)) - -(define-print-method r7rs-source? - (standard-print-method 'r7rs-source - (lambda (source) - (list (r7rs-source-filename source))))) + (libraries r7rs-source-libraries) + (program r7rs-source-program)) + +(define (register-r7rs-source! source db) + (register-libraries! (r7rs-source-libraries source) db) + (let ((program (r7rs-source-program source))) + (if program + (register-library! program db)) + program)) (define (parse-define-library-form form #!optional pathname) (let ((directory diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 8b541309a..16bc6ec0c 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5839,6 +5839,7 @@ USA. (export (runtime library) define-automatic-property host-library-db + library-contents library-db? library-environment library-exporter @@ -5857,6 +5858,7 @@ USA. library-import=? library-import? library-imports + library-imports-environment library-name library-parsed-contents library-parsed-imports @@ -5884,14 +5886,11 @@ USA. parse-define-library-form parse-import-form parse-import-set - r7rs-source-body - r7rs-source-filename - r7rs-source-imports - r7rs-source-parsed-libraries + r7rs-source-program + r7rs-source-libraries r7rs-source? - read-r7rs-source) - (export (runtime load) - read-r7rs-source)) + read-r7rs-source + register-r7rs-source!)) (define-package (runtime library standard) (files "library-standard") diff --git a/tests/check.scm b/tests/check.scm index ed766d51f..4bc61a656 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -66,6 +66,7 @@ USA. ("runtime/test-library-parser" (runtime library)) ("runtime/test-library-standard" (runtime library)) ("runtime/test-library-imports" (runtime library)) + ("runtime/test-library-loader" (runtime library)) "runtime/test-md5" "runtime/test-mime-codec" ("runtime/test-parametric-predicate" (runtime parametric-predicate)) diff --git a/tests/runtime/test-library-data/support-code.scm b/tests/runtime/test-library-data/support-code.scm index d0db663fe..c647bafb1 100644 --- a/tests/runtime/test-library-data/support-code.scm +++ b/tests/runtime/test-library-data/support-code.scm @@ -116,8 +116,7 @@ USA. ,@ex1-contents)) (define (read-dependencies) - (r7rs-source-parsed-libraries - (read-r7rs-source dependencies-filename))) + (r7rs-source-libraries (read-r7rs-source dependencies-filename))) (define dependencies-filename (->namestring diff --git a/tests/runtime/test-library-loader.scm b/tests/runtime/test-library-loader.scm new file mode 100644 index 000000000..19a285a4c --- /dev/null +++ b/tests/runtime/test-library-loader.scm @@ -0,0 +1,52 @@ +#| -*-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. + +|# + +;;;; Tests for library loader + +(declare (usual-integrations)) + +(include "test-library-data/support-code.scm") + +(define-test 'read-r7rs-source:r7rs-example + (lambda () + (let ((source (read-r7rs-source r7rs-example-filename)) + (db (make-library-db 'test))) + (add-standard-libraries! db) + (let ((program (register-r7rs-source! source db))) + (assert-equal (unsyntax (library-contents program)) + '(begin + (define grid (make-grid 24 24)) + (grid-set! grid 1 1 #t) + (grid-set! grid 2 2 #t) + (grid-set! grid 3 0 #t) + (grid-set! grid 3 1 #t) + (grid-set! grid 3 2 #t) + (life grid 80))) + (let ((env (library-imports-environment program))) + (assert-lset= eq? + (environment-bound-names env) + (map library-import-to + (library-imports program)))))))) \ No newline at end of file diff --git a/tests/runtime/test-library-parser.scm b/tests/runtime/test-library-parser.scm index 6b94af3ff..3f7d5b94e 100644 --- a/tests/runtime/test-library-parser.scm +++ b/tests/runtime/test-library-parser.scm @@ -82,7 +82,7 @@ USA. (define-test 'read-r7rs-source:dependencies (lambda () (let ((source (read-r7rs-source dependencies-filename))) - (let ((libraries (r7rs-source-parsed-libraries source))) + (let ((libraries (r7rs-source-libraries source))) (assert-true (list? libraries)) (assert-= (length libraries) 4) (assert-list= equal? @@ -91,33 +91,32 @@ USA. (foo bletch) (foo grumble) (foo quux)))) - (assert-null (r7rs-source-imports source)) - (assert-false (r7rs-source-body source)) - (assert-string= (r7rs-source-filename source) - dependencies-filename)))) + (assert-false (r7rs-source-program source))))) (define-test 'read-r7rs-source:r7rs-example (lambda () (let ((source (read-r7rs-source r7rs-example-filename))) - (let ((libraries (r7rs-source-parsed-libraries source))) + (let ((libraries (r7rs-source-libraries source))) (assert-true (list? libraries)) (assert-= (length libraries) 2) (assert-list= equal? (map library-name libraries) '((example grid) (example life)))) - (assert-equal (r7rs-source-imports source) - '((library (scheme base)) - (only (library (example life)) life) - (rename (prefix (library (example grid)) grid-) - (grid-make . make-grid)))) - (assert-equal (r7rs-source-body source) - '((define grid (make-grid 24 24)) - (grid-set! grid 1 1 #t) - (grid-set! grid 2 2 #t) - (grid-set! grid 3 0 #t) - (grid-set! grid 3 1 #t) - (grid-set! grid 3 2 #t) - (life grid 80))) - (assert-string= (r7rs-source-filename source) - r7rs-example-filename)))) \ No newline at end of file + (let ((program (r7rs-source-program source))) + (assert-equal (library-parsed-imports program) + '((library (scheme base)) + (only (library (example life)) life) + (rename (prefix (library (example grid)) grid-) + (grid-make . make-grid)))) + (assert-equal (library-parsed-contents program) + '((begin + (define grid (make-grid 24 24)) + (grid-set! grid 1 1 #t) + (grid-set! grid 2 2 #t) + (grid-set! grid 3 0 #t) + (grid-set! grid 3 1 #t) + (grid-set! grid 3 2 #t) + (life grid 80)))) + (assert-string= (library-filename program) + r7rs-example-filename))))) \ No newline at end of file -- 2.25.1