(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))
(make-library-db 'host))
\f
(define (make-library name . keylist)
+ (if name
+ (guarantee library-name? name 'make-library))
(let ((alist
(cons* 'library
(cons 'name name)
(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)))
(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))))))
(set-cdr! alist (del-assq! key (cdr alist))))
(define (summarize-self)
- (list name))
+ (if name
+ (list name)
+ '()))
(define (describe-self)
(map (lambda (p)
(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))
(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:"
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)))
(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)
(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)
(eq? 'import (car object))))
(define-record-type <r7rs-source>
- (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))
\f
(define (parse-define-library-form form #!optional pathname)
(let ((directory
(export (runtime library)
define-automatic-property
host-library-db
+ library-contents
library-db?
library-environment
library-exporter
library-import=?
library-import?
library-imports
+ library-imports-environment
library-name
library-parsed-contents
library-parsed-imports
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")
("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))
,@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
--- /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 loader
+
+(declare (usual-integrations))
+\f
+(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
(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?
(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
projects / mit-scheme.git / commitdiff