(declare (usual-integrations))
\f
(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))
(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!)))
(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))
+\f
+(define-record-type <library-metadata>
+ (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 <loaded-library>
+ (%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 <compiled-library>
+ (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
(declare (usual-integrations))
\f
-(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)
(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)
(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)
intersections)))
\f
;;; Returns a list of (<to-name> <from-name> <from-library>) 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)))
(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 <library-import>
+ (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
(declare (usual-integrations))
\f
+;; 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))))
+\f
+(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))
+\f
;;;; 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 <compiled-library>
- (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))
\f
;;;; Load
(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 <loaded-library>
- (%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)
(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)
(declare (usual-integrations))
\f
-(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
length
let
let*
- let*-values
+ ;; let*-values
let-syntax
- let-values
+ ;; let-values
letrec
letrec*
letrec-syntax
negative?
newline
not
- null-environment
+ ;;null-environment
null?
number->string
number?
remainder
reverse
round
- scheme-report-environment
+ ;;scheme-report-environment
set!
set-car!
set-cdr!
system-uri
with-loader-base-uri)
(export (runtime)
+ ;; current-library-db
+ ;; host-library-db
load/purification-root))
(define-package (runtime command-line)
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
(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")
)
(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
"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))
--- /dev/null
+(define-library (foo mumble)
+ (import (scheme base))
+ (export foo-mumble?
+ make-foo-mumble
+ foo-mumble-a
+ foo-mumble-b)
+ (begin
+ (define-record-type <foo-mumble>
+ (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 <foo-bletch>
+ (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 <foo-grumble>
+ (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 <foo-quux>
+ (make-foo-quux a b)
+ foo-quux?
+ (a foo-quux-a)
+ (b foo-quux-b))))
\ No newline at end of file
--- /dev/null
+#| -*-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
+\f
+(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 <bar>
+ (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> foo?))
+
+(define ex2-extra-contents
+ '((begin
+ (define-record-type <foo>
+ (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
--- /dev/null
+#| -*-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))
+\f
+(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
(declare (usual-integrations))
\f
-(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 ()
(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 <bar>
- (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> foo?))
-
-(define ex2-extra-contents
- '((begin
- (define-record-type <foo>
- (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
projects / mit-scheme.git / commitdiff