From 6ab4647ce98404852600c500d0c7977947625480 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 3 Oct 2018 22:59:25 -0700 Subject: [PATCH] Initial draft of test-library-imports, plus bug fixes. --- src/runtime/library-database.scm | 82 ++++++- src/runtime/library-imports.scm | 50 ++-- src/runtime/library-loader.scm | 225 ++++++++++-------- src/runtime/library-parser.scm | 14 -- src/runtime/library-standard.scm | 41 +++- src/runtime/runtime.pkg | 53 +++-- tests/check.scm | 1 + .../test-library-data/dependencies.scm | 49 ++++ .../test-library-data/support-code.scm | 130 ++++++++++ tests/runtime/test-library-imports.scm | 75 ++++++ tests/runtime/test-library-parser.scm | 91 +------ 11 files changed, 556 insertions(+), 255 deletions(-) create mode 100644 tests/runtime/test-library-data/dependencies.scm create mode 100644 tests/runtime/test-library-data/support-code.scm create mode 100644 tests/runtime/test-library-imports.scm diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 6f3066601..b0bc92333 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -30,9 +30,24 @@ USA. (declare (usual-integrations)) (define (make-library-db) - (let ((compiled (make-library-table)) + (let ((metadata (make-library-table)) + (compiled (make-library-table)) (loaded (make-library-table))) + (define (metadata? name) + (metadata 'has? name)) + + (define (get-metadata name #!optional default-value) + (metadata 'get name default-value)) + + (define (save-metadata! library) + (metadata 'put! (library-metadata-name library) library)) + + (define (require-metadata names) + (let ((unknown (remove metadata? names))) + (if (pair? unknown) + (error "Can't resolve libraries:" unknown)))) + (define (compiled? name) (compiled 'has? name)) @@ -57,6 +72,7 @@ USA. (loaded 'put! (loaded-library-name library) library)) (bundle library-db? + metadata? get-metadata save-metadata! require-metadata compiled? get-compiled save-compiled! require-compiled loaded? get-loaded save-loaded!))) @@ -91,4 +107,66 @@ USA. (bundle library-table? has? get put! delete! get-alist put-alist!))) (define library-table? - (make-bundle-predicate 'library-table)) \ No newline at end of file + (make-bundle-predicate 'library-table)) + +(define-record-type + (make-library-metadata name imports exports pathname) + library-metadata? + (name library-metadata-name) + ;; Parsed unexpanded import sets. + (imports library-metadata-imports) + ;; List of external symbols. + (exports library-metadata-exports) + ;; Pathname to file where library is defined. + ;; May be #f in special cases. + (pathname library-metadata-pathname)) + +(define (parsed-library->metadata parsed db) + (make-library-metadata + (parsed-library-name parsed) + (expand-import-sets (parsed-library-imports parsed) db) + (map library-export-to (parsed-library-exports parsed)) + (parsed-library-pathname parsed))) + +(define (make-loaded-library name exports environment) + (%make-loaded-library name + (map library-export-to exports) + (make-exporter exports environment) + environment)) + +(define (make-exporter exports environment) + (let ((export-alist + (map (lambda (export) + (cons (library-export-to export) + (environment-safe-lookup environment + (library-export-from export)))) + exports))) + (lambda (name) + (let ((p (assq name export-alist))) + (if (not p) + (error "Not an exported name:" name)) + (cdr p))))) + +(define-record-type + (%make-loaded-library name exports environment exporter) + loaded-library? + (name loaded-library-name) + (exports loaded-library-exports) + (exporter loaded-library-exporter) + (environment loaded-library-environment)) + +(define-record-type + (make-compiled-library name imports exports body) + compiled-library? + (name compiled-library-name) + (imports compiled-library-imports) + (exports compiled-library-exports) + (body compiled-library-body)) + +(define (compiled-library->scode library) + (make-scode-declaration + `(target-metadata + (library (name ,(compiled-library-name library)) + (imports ,(compiled-library-imports library)) + (exports ,(compiled-library-exports library)))) + (make-scode-quotation (compiled-library-body library)))) \ No newline at end of file diff --git a/src/runtime/library-imports.scm b/src/runtime/library-imports.scm index 9298307f7..c86dbaf92 100644 --- a/src/runtime/library-imports.scm +++ b/src/runtime/library-imports.scm @@ -29,11 +29,11 @@ USA. (declare (usual-integrations)) -(define (convert-import-sets import-sets library-db) - (library-db 'require-compiled (import-sets->libraries import-sets)) +(define (expand-import-sets import-sets library-db) + (library-db 'require-metadata (import-sets->libraries import-sets)) (let ((converted-sets (map (lambda (import-set) - (convert-import-set import-set library-db)) + (expand-import-set import-set library-db)) import-sets))) (let ((intersections (find-intersections converted-sets))) (if (pair? intersections) @@ -44,7 +44,7 @@ USA. (append-map (lambda (set) set) converted-sets))) (define (import-sets->libraries import-sets) - (delete-duplicates (append-map import-set->library import-sets) + (delete-duplicates (map import-set->library import-sets) equal?)) (define (import-set->library import-set) @@ -63,7 +63,7 @@ USA. (map library-import-to links2)) (list links1 links2))) (cdr converted-sets)) - (find-intersections converted-sets))) + (find-intersections (cdr converted-sets)))) '())) (define (intersecting-names? names1 names2) @@ -78,21 +78,20 @@ USA. intersections))) ;;; Returns a list of ( ) elements. -(define (convert-import-set import-set library-db) +(define (expand-import-set import-set library-db) (let ((converted-set (let loop ((import-set import-set) (filter (lambda (name) name))) (case (car import-set) ((library) (let ((library-name (cadr import-set))) - (filter-map (lambda (export) - (let* ((name (library-export-to export)) - (filtered (filter name))) + (filter-map (lambda (name) + (let ((filtered (filter name))) (and filtered (make-library-import filtered name library-name)))) - (compiled-library-exports - (library-db 'get-compiled library-name))))) + (library-metadata-exports + (library-db 'get-metadata library-name))))) ((only) (loop (cadr import-set) (let ((names (cddr import-set))) @@ -132,11 +131,24 @@ USA. (or (eq? (car names) (cadr names)) (loop (cdr names))))))) -(define (make-library-import to from from-library) (list to from from-library)) -(define (library-import-to import) (car import)) -(define (library-import-from import) (cadr import)) -(define (library-import-from-library import) (caddr import)) - -(define (make-library-export from to) (cons from to)) -(define (library-export-from export) (car export)) -(define (library-export-to export) (cdr export)) \ No newline at end of file +(define-record-type + (make-library-import to from from-library) + library-import? + (to library-import-to) + (from library-import-from) + (from-library library-import-from-library)) + +(define-print-method library-import? + (standard-print-method 'library-import + (lambda (import) + (list (library-import-to import) + (library-import-from import) + (library-import-from-library import))))) + +(define (library-import=? e1 e2) + (and (eq? (library-import-to e1) + (library-import-to e2)) + (eq? (library-import-from e1) + (library-import-from e2)) + (equal? (library-import-from-library e1) + (library-import-from-library e2)))) \ No newline at end of file diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm index 3ec702e7f..d819adb54 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -29,70 +29,123 @@ USA. (declare (usual-integrations)) +;; Returns one of the following: +;; * Zero or more libraries, one or more imports, and a body. +;; * Zero or more libraries, no imports, and no body. +;; * #F, meaning this isn't R7RS source. +(define (read-r7rs-source pathname) + (parameterize ((param:reader-fold-case? #f)) + (call-with-input-file pathname + (lambda (port) + + (define (read-libs libs) + (let ((form (read port))) + (cond ((eof-object? form) + (make-r7rs-source (reverse libs) '() #f)) + ((r7rs-library? form) + (read-libs + (cons (parse-define-library-form form pathname) + libs))) + ((r7rs-import? form) + (read-imports (list (parse-import-form form)) + (reverse libs))) + ;; Not a valid R7RS file. + (else #f)))) + + (define (read-imports imports libs) + (let ((form (read port))) + (if (eof-object? form) + (error "EOF while reading imports")) + (if (r7rs-library? form) + (error "Can't mix libraries and imports:" form)) + (if (r7rs-import? form) + (read-imports (cons (parse-import-form form) imports) libs) + (make-r7rs-source libs + (append-map cdr (reverse imports)) + (read-body (list form)))))) + + (define (read-body forms) + (let ((form (read port))) + (if (eof-object? form) + (reverse forms) + (read-body (cons form forms))))) + + (read-libs '()))))) + +(define (r7rs-library? object) + (and (pair? object) + (eq? 'define-library (car object)))) + +(define (r7rs-import? object) + (and (pair? object) + (eq? 'import (car object)))) + +(define (make-r7rs-source libraries imports body) + + (define (save-metadata! library-db) + ;; TODO: adjust expansion order due to dependencies. + (for-each + (lambda (library) + (library-db 'save-metadata! + (parsed-library->metadata library library-db))) + libraries)) + + (define (load library-db) + (for-each (lambda (library) + (load-library (compile-library library library-db) + library-db)) + libraries) + (if (pair? imports) + (let ((environment* + (expanded-imports->environment + (expand-import-sets imports library-db)))) + (let loop ((exprs body) (value unspecific)) + (if (pair? exprs) + (loop (cdr exprs) + (eval (car exprs) environment*)) + value))))) + + (bundle r7rs-source? save-metadata! load)) + +(define r7rs-source? + (make-bundle-predicate 'r7rs-source)) + ;;;; Compile -(define (compile-library form library-db) - (let ((library (parse-define-library-form form))) - (let ((imports - (convert-import-sets (parsed-library-imports library) - library-db))) - (make-compiled-library (parsed-library-name library) - imports - (parsed-library-exports library) - (compile-contents library library-db))))) - -(define (compile-contents library library-db) - (let ((imports (parsed-library-imports library)) - (exports (parsed-library-exports library))) - (receive (body bound free) - (syntax-library-forms - (append-map (lambda (directive) - (case (car directive) - ((include) - (fluid-let ((param:reader-fold-case? #f)) - (append-map (lambda (pathname) - (call-with-input-file pathname - read-file)) - (cdr directive)))) - ((include-ci) - (fluid-let ((param:reader-fold-case? #t)) - (append-map (lambda (pathname) - (call-with-input-file pathname - read-file)) - (cdr directive)))) - ((begin) - (cdr directive)) - (else - (error "Unknown content directive:" directive)))) - (parsed-library-contents library)) - (converted-imports->environment imports library-db)) - (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:" - (lset-difference eq? - exports-from - (lset-union eq? bound free))))) - (let ((imports-to (map library-import-to imports))) - (if (not (lset<= eq? free imports-to)) - (warn "Library has free references not provided by imports:" - (lset-difference eq? free imports-to)))) - body))) - -(define-record-type - (make-compiled-library name imports exports body) - compiled-library? - (name compiled-library-name) - (imports compiled-library-imports) - (exports compiled-library-exports) - (body compiled-library-body)) - -(define (compiled-library->scode library) - (make-scode-declaration - `(target-metadata - (library (name ,(compiled-library-name library)) - (imports ,(compiled-library-imports library)) - (exports ,(compiled-library-exports library)))) - (make-scode-quotation (compiled-library-body library)))) +(define (compile-library library db) + (let ((name (parsed-library-name library)) + (imports + (expand-import-sets (parsed-library-imports library) + db)) + (exports (parsed-library-exports library)) + (contents (expand-parsed-contents (parsed-library-contents library)))) + (db 'save-compiled! + (make-compiled-library name + imports + exports + (compile-contents contents + imports + (map library-export-from + exports) + db) + db)) + name)) + +(define (compile-contents contents imports exports-from library-db) + (receive (body bound free) + (syntax-library-forms contents + (expanded-imports->environment imports + library-db)) + (if (not (lset<= eq? exports-from (lset-union eq? bound free))) + (warn "Library export refers to unbound identifiers:" + (lset-difference eq? + exports-from + (lset-union eq? bound free)))) + (let ((imports-to (map library-import-to imports))) + (if (not (lset<= eq? free imports-to)) + (warn "Library has free references not provided by imports:" + (lset-difference eq? free imports-to)))) + body)) ;;;; Load @@ -100,54 +153,26 @@ USA. (or (library-db 'get-loaded library-name #f) (let ((compiled (library-db 'get-compiled library-name))) (let ((environment - (converted-imports->environment + (expanded-imports->environment (compiled-library-imports compiled) library-db))) (scode-eval (compiled-library-body compiled) environment) - (make-loaded-library (compiled-library-name compiled) - (compiled-library-exports compiled) - environment - library-db))))) - -(define (make-loaded-library name exports environment library-db) - (let ((library - (%make-loaded-library name - (map library-export-to exports) - (make-exporter exports environment) - environment))) - (library-db 'save-loaded! library) - library)) - -(define (make-exporter exports environment) - (let ((export-alist - (map (lambda (export) - (cons (library-export-to export) - (environment-safe-lookup environment - (library-export-from export)))) - exports))) - (lambda (name) - (let ((p (assq name export-alist))) - (if (not p) - (error "Not an exported name:" name)) - (cdr p))))) - -(define-record-type - (%make-loaded-library name environment exporter) - loaded-library? - (name loaded-library-name) - (exports loaded-library-exports) - (exporter loaded-library-exporter) - (environment loaded-library-environment)) + (let ((loaded + (make-loaded-library (compiled-library-name compiled) + (compiled-library-exports compiled) + environment))) + (library-db 'save-loaded! loaded) + loaded))))) (define (library-exporter library-name library-db) (loaded-library-exporter (load-library library-name library-db))) (define (environment . import-sets) - (converted-imports->environment - (convert-import-sets (map parse-import-set import-sets)))) + (expanded-imports->environment + (expand-import-sets (map parse-import-set import-sets)))) -(define (converted-imports->environment imports library-db) +(define (expanded-imports->environment imports library-db) (let ((env (make-root-top-level-environment (map library-import-to imports)))) (for-each (lambda (import) diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm index 07f36553a..280690acd 100644 --- a/src/runtime/library-parser.scm +++ b/src/runtime/library-parser.scm @@ -254,20 +254,6 @@ USA. (exact-nonnegative-integer? elt))) object))) -(define (parsed-exports-from exports) - (map (lambda (export) - (if (pair? export) - (car export) - export)) - exports)) - -(define (parsed-exports-to exports) - (map (lambda (export) - (if (pair? export) - (cdr export) - export)) - exports)) - (define (expand-parsed-contents contents) (append-map (lambda (directive) (case (car directive) diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index 12b8fe77e..db0042f70 100644 --- a/src/runtime/library-standard.scm +++ b/src/runtime/library-standard.scm @@ -29,16 +29,35 @@ USA. (declare (usual-integrations)) -(define (add-standard-libraries library-db) +(define (add-standard-libraries! db) (for-each (lambda (p) - (make-loaded-library (car p) - (map (lambda (id) - (make-library-export id id)) - (cdr p)) - system-global-environment - library-db)) + (let ((name (car p)) + (exports (cdr p))) + (db 'save-metadata! + (make-library-metadata name '() exports #f)) + (db 'save-loaded! + (make-loaded-library name + (map (lambda (id) + (make-library-export id id)) + exports) + system-global-environment)))) standard-libraries)) +(define (check-standard-libraries!) + (for-each (lambda (p) + (check-standard-library! (car p) (cdr p))) + standard-libraries)) + +(define (check-standard-library! name exports) + (let ((missing + (remove (lambda (name) + (memq (environment-reference-type system-global-environment + name) + '(normal macro))) + exports))) + (if (pair? missing) + (warn "Missing definitions for library:" name missing)))) + (define (define-standard-library name exports) (let ((p (assoc name standard-libraries))) (if p @@ -163,9 +182,9 @@ USA. length let let* - let*-values + ;; let*-values let-syntax - let-values + ;; let-values letrec letrec* letrec-syntax @@ -567,7 +586,7 @@ USA. negative? newline not - null-environment + ;;null-environment null? number->string number? @@ -593,7 +612,7 @@ USA. remainder reverse round - scheme-report-environment + ;;scheme-report-environment set! set-car! set-cdr! diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 39f0f479f..3dfe25cf6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3174,6 +3174,8 @@ USA. system-uri with-loader-base-uri) (export (runtime) + ;; current-library-db + ;; host-library-db load/purification-root)) (define-package (runtime command-line) @@ -5845,8 +5847,6 @@ USA. parse-define-library-form parse-import-form parse-import-set - parsed-exports-from - parsed-exports-to parsed-library-contents parsed-library-exports parsed-library-imports @@ -5858,23 +5858,46 @@ USA. (files "library-database") (parent (runtime library)) (export (runtime library) + compiled-library->scode + compiled-library-body + compiled-library-exports + compiled-library-imports + compiled-library-name + compiled-library? library-db? - make-library-db)) + library-metadata-exports + library-metadata-imports + library-metadata-name + library-metadata-pathname + library-metadata? + loaded-library-environment + loaded-library-exporter + loaded-library-exports + loaded-library-name + make-compiled-library + make-library-db + make-library-metadata + make-loaded-library + parsed-library->metadata)) (define-package (runtime library standard) (files "library-standard") (parent (runtime library)) (export (runtime library) - add-standard-libraries)) + add-standard-libraries! + check-standard-libraries!)) (define-package (runtime library imports) (files "library-imports") (parent (runtime library)) (export (runtime library) - convert-import-sets + expand-import-sets library-import-from library-import-from-library - library-import-to)) + library-import-to + library-import=? + library-import? + make-library-import)) (define-package (runtime library loader) (files "library-loader") @@ -5884,18 +5907,8 @@ USA. ) (export (runtime library) compile-library - compiled-library->scode - compiled-library-body - compiled-library-exports - compiled-library-imports - compiled-library-name - compiled-library? - converted-imports->environment + expanded-imports->environment library-exporter - load-library - loaded-library-environment - loaded-library-exporter - loaded-library-exports - loaded-library-name - loaded-library? - make-loaded-library)) \ No newline at end of file + load-library) + (export (runtime load) + read-r7rs-source)) \ No newline at end of file diff --git a/tests/check.scm b/tests/check.scm index 33cebe75e..e9472720b 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -64,6 +64,7 @@ USA. "runtime/test-hash-table" "runtime/test-integer-bits" ("runtime/test-library-parser" (runtime library)) + ("runtime/test-library-imports" (runtime library)) "runtime/test-md5" "runtime/test-mime-codec" ("runtime/test-parametric-predicate" (runtime parametric-predicate)) diff --git a/tests/runtime/test-library-data/dependencies.scm b/tests/runtime/test-library-data/dependencies.scm new file mode 100644 index 000000000..e4c732de8 --- /dev/null +++ b/tests/runtime/test-library-data/dependencies.scm @@ -0,0 +1,49 @@ +(define-library (foo mumble) + (import (scheme base)) + (export foo-mumble? + make-foo-mumble + foo-mumble-a + foo-mumble-b) + (begin + (define-record-type + (make-foo-mumble a b) + foo-mumble? + (a foo-mumble-a) + (b foo-mumble-b)))) + +(define-library (foo bletch) + (import (scheme base)) + (export foo-bletch? + make-foo-bletch + foo-bletch-thing) + (begin + (define-record-type + (make-foo-bletch thing b) + foo-bletch? + (thing foo-bletch-thing)))) + +(define-library (foo grumble) + (import (scheme base)) + (export foo-grumble? + make-foo-grumble + foo-grumble-a + foo-grumble-b) + (begin + (define-record-type + (make-foo-grumble a b) + foo-grumble? + (a foo-grumble-a) + (b foo-grumble-b)))) + +(define-library (foo quux) + (import (scheme base)) + (export foo-quux? + make-foo-quux + foo-quux-a + foo-quux-b) + (begin + (define-record-type + (make-foo-quux a b) + foo-quux? + (a foo-quux-a) + (b foo-quux-b)))) \ No newline at end of file diff --git a/tests/runtime/test-library-data/support-code.scm b/tests/runtime/test-library-data/support-code.scm new file mode 100644 index 000000000..ca2973b50 --- /dev/null +++ b/tests/runtime/test-library-data/support-code.scm @@ -0,0 +1,130 @@ +#| -*-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. + +|# + +;;;; Support for library tests + +(define test-pathname + (current-load-pathname)) + +(define test-directory + (directory-pathname test-pathname)) + +(define-comparator library-export=? 'library-export=?) +(define-comparator library-import=? 'library-import=?) + +(define (convert-import import) + (case (car import) + ((only except prefix) + `(,(car import) + (library ,(cadr import)) + ,@(cddr import))) + ((rename) + `(,(car import) + (library ,(cadr import)) + ,@(map (lambda (p) + (cons (car p) (cadr p))) + (cddr import)))) + (else + `(library ,import)))) + +(define (convert-export export) + (if (symbol? export) + (make-library-export export) + (make-library-export (cadr export) (caddr export)))) + +(define (convert-content content) + (case (car content) + ((include include-ci) + (map (lambda (path) + (list (merge-pathnames path test-directory) (car content))) + (cdr content))) + ((begin) + (cdr content)) + (else + (error "Unknown content:" content)))) + +(define ex1-imports + '((foo mumble) + (only (foo bletch) make-bletch bletch? bletch-thing) + (prefix (foo grumble) grumble-) + (except (foo quux) make-foo-quux) + (rename (only (foo quux) make-foo-quux) (make-foo-quux create-foo-quux)))) + +(define ex1-exports + '(make-bar + bar? + bar-v1 + bar-v2 + (rename set-bar-v1! bar-v1!))) + +(define ex1-contents + '((include "foo-bar-1") + (include-ci "foo-bar-2") + (begin + (define-record-type + (make-bar v1 v2) + bar? + (v1 bar-v1 set-bar-v1!) + (v2 bar-v2))))) + +(define ex1 + `(define-library (foo bar) + (import ,@ex1-imports) + (export ,@ex1-exports) + ,@ex1-contents)) + +(define ex2-extra-imports + '((scheme base))) + +(define ex2-extra-exports + '( foo?)) + +(define ex2-extra-contents + '((begin + (define-record-type + (make-foo) + foo?)))) + +(define ex2 + `(define-library (foo bar) + (import ,@ex1-imports) + (export ,@ex1-exports) + (include-library-declarations "test-library-data/foo-foo") + ,@ex1-contents)) + +(define (build-metadata-db) + (let ((db (make-library-db))) + (add-standard-libraries! db) + (let ((path + (merge-pathnames "test-library-data/dependencies.scm" + test-directory))) + (for-each (lambda (form) + (db 'save-metadata! + (parsed-library->metadata + (parse-define-library-form form path) + db))) + (read-file path))) + db)) \ No newline at end of file diff --git a/tests/runtime/test-library-imports.scm b/tests/runtime/test-library-imports.scm new file mode 100644 index 000000000..1548ca992 --- /dev/null +++ b/tests/runtime/test-library-imports.scm @@ -0,0 +1,75 @@ +#| -*-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 import management + +(declare (usual-integrations)) + +(include "test-library-data/support-code.scm") + +(define-test 'expand-import-sets:ex1 + (lambda () + (assert-lset= library-import=? + (expand-import-sets (parsed-library-imports + (parse-define-library-form ex1 + test-pathname)) + (build-metadata-db)) + (list (make-library-import 'foo-mumble? + 'foo-mumble? + '(foo mumble)) + (make-library-import 'make-foo-mumble + 'make-foo-mumble + '(foo mumble)) + (make-library-import 'foo-mumble-a + 'foo-mumble-a + '(foo mumble)) + (make-library-import 'foo-mumble-b + 'foo-mumble-b + '(foo mumble)) + (make-library-import 'grumble-foo-grumble? + 'foo-grumble? + '(foo grumble)) + (make-library-import 'grumble-make-foo-grumble + 'make-foo-grumble + '(foo grumble)) + (make-library-import 'grumble-foo-grumble-a + 'foo-grumble-a + '(foo grumble)) + (make-library-import 'grumble-foo-grumble-b + 'foo-grumble-b + '(foo grumble)) + (make-library-import 'foo-quux? + 'foo-quux? + '(foo quux)) + (make-library-import 'foo-quux-a + 'foo-quux-a + '(foo quux)) + (make-library-import 'foo-quux-b + 'foo-quux-b + '(foo quux)) + (make-library-import 'create-foo-quux + 'make-foo-quux + '(foo quux)))))) \ No newline at end of file diff --git a/tests/runtime/test-library-parser.scm b/tests/runtime/test-library-parser.scm index 47909b5d0..9f095f96d 100644 --- a/tests/runtime/test-library-parser.scm +++ b/tests/runtime/test-library-parser.scm @@ -28,14 +28,7 @@ USA. (declare (usual-integrations)) -(define test-pathname - (current-load-pathname)) - -(define test-directory - (directory-pathname test-pathname)) - -(define-comparator library-export=? - 'library-export=?) +(include "test-library-data/support-code.scm") (define-test 'parse-library:empty (lambda () @@ -86,84 +79,4 @@ USA. (append-map convert-content (append ex2-extra-contents ex1-contents))) (assert-equal (parsed-library-pathname parsed) - test-pathname)))) - -(define (convert-import import) - (case (car import) - ((only except prefix) - `(,(car import) - (library ,(cadr import)) - ,@(cddr import))) - ((rename) - `(,(car import) - (library ,(cadr import)) - ,@(map (lambda (p) - (cons (car p) (cadr p))) - (cddr import)))) - (else - `(library ,import)))) - -(define (convert-export export) - (if (symbol? export) - (make-library-export export) - (make-library-export (cadr export) (caddr export)))) - -(define (convert-content content) - (case (car content) - ((include include-ci) - (map (lambda (path) - (list (merge-pathnames path test-directory) (car content))) - (cdr content))) - ((begin) - (cdr content)) - (else - (error "Unknown content:" content)))) - -(define ex1-imports - '((foo mumble) - (only (foo bletch) make-bletch bletch? bletch-thing) - (prefix (foo grumble) grumble-) - (except (foo quux) make-quux) - (rename (foo quux) (make-quux create-quux)))) - -(define ex1-exports - '(make-bar - bar? - bar-v1 - bar-v2 - (rename set-bar-v1! bar-v1!))) - -(define ex1-contents - '((include "foo-bar-1") - (include-ci "foo-bar-2") - (begin - (define-record-type - (make-bar v1 v2) - bar? - (v1 bar-v1 set-bar-v1!) - (v2 bar-v2))))) - -(define ex1 - `(define-library (foo bar) - (import ,@ex1-imports) - (export ,@ex1-exports) - ,@ex1-contents)) - -(define ex2-extra-imports - '((scheme base))) - -(define ex2-extra-exports - '( foo?)) - -(define ex2-extra-contents - '((begin - (define-record-type - (make-foo) - foo?)))) - -(define ex2 - `(define-library (foo bar) - (import ,@ex1-imports) - (export ,@ex1-exports) - (include-library-declarations "test-library-data/foo-foo") - ,@ex1-contents)) \ No newline at end of file + test-pathname)))) \ No newline at end of file -- 2.25.1