(declare (usual-integrations))
\f
-(define (make-library-db)
- (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 (make-library-db name)
+ (let ((table (make-equal-hash-table)))
- (define (compiled? name)
- (compiled 'has? name))
+ (define (has? name)
+ (hash-table-exists? table name))
- (define (get-compiled name #!optional default-value)
- (compiled 'get name default-value))
+ (define (get name)
+ (hash-table-ref table name))
- (define (save-compiled! library)
- (compiled 'put! (compiled-library-name library) library))
+ (define (put! library)
+ (if (and (library 'has? 'db)
+ (not (eq? (library 'get 'db) this)))
+ (error "Can't use library in multiple databases:" library))
+ (let ((name (library 'get 'name)))
+ (if (has? name)
+ (warn "Overwriting library:" name))
+ (library 'put! 'db this)
+ (hash-table-set! table name library)))
- (define (require-compiled names)
- (let ((unknown (remove compiled? names)))
- (if (pair? unknown)
- (error "Can't resolve libraries:" unknown))))
+ (define (get-names)
+ (hash-table-keys table))
- (define (loaded? name)
- (loaded 'has? name))
+ (define (get-all)
+ (hash-table-values table))
- (define (get-loaded name #!optional default-value)
- (loaded 'get name default-value))
+ (define (summarize-self)
+ (list name))
- (define (save-loaded! library)
- (loaded 'put! (loaded-library-name library) library))
+ (define (describe-self)
+ (map (lambda (library)
+ (list 'library library))
+ (get-all)))
- (bundle library-db?
- metadata? get-metadata save-metadata! require-metadata
- compiled? get-compiled save-compiled! require-compiled
- loaded? get-loaded save-loaded!)))
+ (define this
+ (bundle library-db?
+ has? get put! get-names get-all
+ summarize-self describe-self))
+ this))
(define library-db?
(make-bundle-predicate 'library-database))
-(define (make-library-table)
- (let ((table (make-equal-hash-table)))
-
- (define (has? name)
- (hash-table-exists? table name))
-
- (define (get name #!optional default-value)
- (if (default-object? default-value)
- (hash-table-ref table name)
- (hash-table-ref/default table name default-value)))
-
- (define (put! name value)
- (hash-table-set! table name value))
+(define-deferred host-library-db
+ (make-library-db 'host))
+\f
+(define (make-library name . keylist)
+ (let ((alist
+ (cons* 'library
+ (cons 'name name)
+ (keyword-list->alist keylist))))
+
+ (define (has? key)
+ (if (assq key (cdr alist))
+ #t
+ (let ((auto (automatic-property key)))
+ (and auto
+ (auto-runnable? auto this)))))
+
+ (define (get key)
+ (let ((p (assq key (cdr alist))))
+ (if p
+ (cdr p)
+ (let ((auto (automatic-property key)))
+ (if (not auto)
+ (error "Unknown library property:" key))
+ (if (not (auto-runnable? auto this))
+ (error "Auto property not ready:" auto))
+ (let ((value (run-auto auto this)))
+ (set-cdr! alist (cons (cons key value) (cdr alist)))
+ value)))))
+
+ (define (put! key value)
+ (if (automatic-property? key)
+ (error "Can't overwrite automatic property:" key))
+ (let ((p (assq key (cdr alist))))
+ (if p
+ (begin
+ (warn "Overwriting library property:" key name)
+ (set-cdr! p value))
+ (set-cdr! alist (cons (cons key value) (cdr alist))))))
+
+ (define (intern! key get-value)
+ (let ((p (assq key (cdr alist))))
+ (if p
+ (cdr p)
+ (let ((value (get-value)))
+ (set-cdr! alist (cons (cons key value) (cdr alist)))
+ value))))
(define (delete! key)
- (hash-table-delete! table key))
+ (set-cdr! alist (del-assq! key (cdr alist))))
- (define (get-alist)
- (hash-table->alist table))
+ (define (summarize-self)
+ (list name))
- (define (put-alist! alist*)
- (for-each (lambda (p)
- (put! (car p) (cdr p)))
- alist*))
+ (define (describe-self)
+ (map (lambda (p)
+ (list (car p) (cdr p)))
+ (cdr alist)))
- (bundle library-table? has? get put! delete! get-alist put-alist!)))
+ (define this
+ (bundle library?
+ has? get put! intern! delete! summarize-self describe-self))
+ this))
-(define library-table?
- (make-bundle-predicate 'library-table))
+(define library?
+ (make-bundle-predicate 'library))
+\f
+;;;; Automatic properties
+
+(define (define-automatic-property prop deps guard generator)
+ (guarantee symbol? prop 'define-automatic-property)
+ (guarantee-list-of symbol? deps 'define-automatic-property)
+ (let ((p (assq prop automatic-properties))
+ (e (cons* generator guard deps)))
+ (if p
+ (set-cdr! p e)
+ (begin
+ (set! automatic-properties
+ (cons (cons prop e)
+ automatic-properties))
+ unspecific))))
+
+(define auto-key car)
+(define auto-generator cadr)
+(define auto-guard caddr)
+(define auto-deps cdddr)
+
+(define (automatic-property? prop)
+ (and (assq prop automatic-properties) #t))
+
+(define (automatic-property prop)
+ (assq prop automatic-properties))
+
+(define automatic-properties '())
+
+(define (auto-runnable? auto library)
+ (and (every (lambda (key)
+ (library 'has? key))
+ (auto-deps auto))
+ (or (not (auto-guard auto))
+ (apply (auto-guard auto)
+ (map (lambda (key)
+ (library 'get key))
+ (auto-deps auto))))))
+
+(define (run-auto auto library)
+ (apply (auto-generator auto)
+ (map (lambda (key)
+ (library 'get key))
+ (auto-deps auto))))
+\f
+;;;; Imports and exports
+
+(define (make-library-import from-library from #!optional to)
+ (guarantee library-name? from-library 'make-library-import)
+ (guarantee symbol? from 'make-library-import)
+ (%make-library-import from-library from
+ (if (default-object? to)
+ from
+ (begin
+ (guarantee symbol? to 'make-library-import)
+ to))))
+
+(define-record-type <library-import>
+ (%make-library-import from-library from to)
+ library-import?
+ (from-library library-import-from-library)
+ (from library-import-from)
+ (to library-import-to))
+
+(define (library-import=? e1 e2)
+ (and (library-name=? (library-import-from-library e1)
+ (library-import-from-library e2))
+ (eq? (library-import-from e1)
+ (library-import-from e2))
+ (eq? (library-import-to e1)
+ (library-import-to e2))))
+
+(define (library-import->list import)
+ (list (library-import-from-library import)
+ (library-import-from import)
+ (library-import-to import)))
+
+(define (list->library-import list)
+ (make-library-import (car list)
+ (cadr list)
+ (caddr list)))
+
+(define (library-imports-from imports)
+ (delete-duplicates (map library-import-from-library imports)
+ library-name=?))
+
+(define-print-method library-import?
+ (standard-print-method 'library-import
+ library-import->list))
+
+(define (make-library-export from #!optional to)
+ (guarantee symbol? from 'make-library-export)
+ (if (default-object? to)
+ (%make-library-export from from)
+ (begin
+ (guarantee symbol? to 'make-library-export)
+ (%make-library-export from to))))
+
+(define-record-type <library-export>
+ (%make-library-export from to)
+ library-export?
+ (from library-export-from)
+ (to library-export-to))
+
+(define (library-export=? e1 e2)
+ (and (eq? (library-export-from e1)
+ (library-export-from e2))
+ (eq? (library-export-to e1)
+ (library-export-to e2))))
+
+(define (library-export->list export)
+ (list (library-export-from export)
+ (library-export-to export)))
+
+(define (list->library-export list)
+ (make-library-export (car list) (cadr list)))
+
+(define-print-method library-export?
+ (standard-print-method 'library-export
+ library-export->list))
\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 exporter environment)
- 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
+;;;; Library accessors
+
+(define (registered-library? name db)
+ (db 'has? name))
+
+(define (registered-library name db)
+ (db 'get name))
+
+(define (registered-libraries db)
+ (db 'get-all))
+
+(define (register-library! library db)
+ (guarantee library? library 'register-library!)
+ (guarantee library-db? db 'register-library!)
+ (db 'put! library))
+
+(define (register-libraries! libraries db)
+ (for-each (lambda (library)
+ (register-library! library db))
+ libraries))
+
+(define (library-accessor key)
+ (lambda (library)
+ (library 'get key)))
+
+(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-name (library-accessor 'name))
+(define library-parsed-contents (library-accessor 'parsed-contents))
+(define library-parsed-imports (library-accessor 'parsed-imports))
+(define library-syntaxed-contents (library-accessor 'syntaxed-contents))
\ No newline at end of file
(declare (usual-integrations))
\f
-(define (expand-import-sets import-sets library-db)
- (library-db 'require-metadata (import-sets->libraries import-sets))
+(define (parsed-imports-expandable? imports db)
+ (every (lambda (import)
+ (parsed-import-expandable? import db))
+ imports))
+
+(define (parsed-import-expandable? import db)
+ (let ((name (parsed-import-library import)))
+ (and (registered-library? name db)
+ ((registered-library name db) 'has? 'exports))))
+
+(define (expand-parsed-imports imports db)
(let ((converted-sets
- (map (lambda (import-set)
- (expand-import-set import-set library-db))
- import-sets)))
+ (map (lambda (import)
+ (expand-parsed-import import db))
+ imports)))
(let ((intersections (find-intersections converted-sets)))
(if (pair? intersections)
(error "Import sets intersect:"
(unconvert-intersections intersections
converted-sets
- import-sets))))
- (append-map (lambda (set) set) converted-sets)))
+ imports))))
+ (reduce-right append! '() converted-sets)))
-(define (import-sets->libraries import-sets)
- (delete-duplicates (map import-set->library import-sets)
- equal?))
-
-(define (import-set->library import-set)
- (case (car import-set)
- ((library) (cadr import-set))
- ((only except prefix rename) (import-set->library (cadr import-set)))
- (else (error "Unrecognized import set:" import-set))))
+(define-automatic-property 'imports '(parsed-imports db)
+ parsed-imports-expandable?
+ expand-parsed-imports)
(define (find-intersections converted-sets)
(if (pair? converted-sets)
intersection))
intersections)))
\f
-;;; Returns a list of (<to-name> <from-name> <from-library>) elements.
-(define (expand-import-set import-set library-db)
+;;; Returns a list of library-import elements.
+(define (expand-parsed-import import-set 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 (name)
- (let ((filtered (filter name)))
+ (let ((name (cadr import-set)))
+ (filter-map (lambda (export)
+ (let* ((to (library-export-to export))
+ (filtered (filter to)))
(and filtered
- (make-library-import library-name
- name
- filtered))))
- (library-metadata-exports
- (library-db 'get-metadata library-name)))))
+ (make-library-import name to filtered))))
+ ((registered-library name db) 'get 'exports))))
((only)
(loop (cadr import-set)
(let ((names (cddr import-set)))
(let loop ((names (sort names symbol<?)))
(and (pair? (cdr names))
(or (eq? (car names) (cadr names))
- (loop (cdr names)))))))
-
-(define (make-library-import from-library from #!optional to)
- (%make-library-import from-library from
- (if (default-object? to) from to)))
-
-(define-record-type <library-import>
- (%make-library-import from-library from to)
- library-import?
- (from-library library-import-from-library)
- (from library-import-from)
- (to library-import-to))
-
-(define-print-method library-import?
- (standard-print-method 'library-import
- (lambda (import)
- (list (library-import-from-library import)
- (library-import-from import)
- (library-import-to import)))))
-
-(define (library-import=? e1 e2)
- (and (equal? (library-import-from-library e1)
- (library-import-from-library e2))
- (eq? (library-import-from e1)
- (library-import-from e2))
- (eq? (library-import-to e1)
- (library-import-to e2))))
\ No newline at end of file
+ (loop (cdr names)))))))
\ 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))))
+;;;; Syntax
+
+(define-automatic-property '->scode '(name imports exports syntaxed-contents)
+ #f
+ (lambda (name imports exports contents)
+ (make-scode-declaration
+ `(target-metadata
+ (library (name ,name)
+ (imports ,(map library-import->list imports))
+ (exports ,(map library-export->list exports))))
+ (make-scode-quotation contents))))
+
+(define-automatic-property 'evaluable-contents
+ '(parsed-contents imports exports db)
+ #f
+ (lambda (contents imports exports db)
+ (receive (body bound free)
+ (syntax-library-forms (expand-contents contents)
+ (imports->environment imports 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 (expand-contents contents)
+ (append-map (lambda (directive)
+ (case (car directive)
+ ((include)
+ (parameterize ((param:reader-fold-case? #f))
+ (append-map read-file
+ (cdr directive))))
+ ((include-ci)
+ (parameterize ((param:reader-fold-case? #t))
+ (append-map read-file
+ (cdr directive))))
+ ((begin)
+ (cdr directive))
+ (else
+ (error "Unknown content directive:" directive))))
+ contents))
\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 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
-
-(define (load-library library-name library-db)
- (or (library-db 'get-loaded library-name #f)
- (let ((compiled (library-db 'get-compiled library-name)))
- (let ((environment
- (expanded-imports->environment
- (compiled-library-imports compiled)
- library-db)))
- (scode-eval (compiled-library-body compiled)
- 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)
- (expanded-imports->environment
- (expand-import-sets (map parse-import-set import-sets))))
-
-(define (expanded-imports->environment imports library-db)
+(define (imports->environment imports db)
+ (if (not (import-environments-available? imports db))
+ (error "Imported libraries unavailable:"
+ (library-imports-from
+ (remove import-environment-available? imports))))
+ (make-environment-from-imports imports db))
+
+(define (import-environments-available? imports db)
+ (every (lambda (import)
+ (import-environment-available? import db))
+ imports))
+
+(define (import-environment-available? import db)
+ (let ((name (library-import-from-library import)))
+ (and (registered-library? name db)
+ ((registered-library name db) 'has? 'environment))))
+
+(define (make-environment-from-imports imports db)
(let ((env
(make-root-top-level-environment (map library-import-to imports))))
(for-each (lambda (import)
(let ((value
- (library-exporter
- (library-import-from-library import)
- library-db))
+ ((library-exporter
+ (registered-library
+ (library-import-from-library import)
+ db))
+ (library-import-from import)))
(name (library-import-to import)))
(cond ((macro-reference-trap? value)
(environment-define-macro
(else
(environment-define env name value)))))
imports)
- env))
\ No newline at end of file
+ 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 (environment . import-sets)
+ (let ((parsed (map parse-import-set import-sets)))
+ (let ((unusable (remove parsed-import-expandable? parsed)))
+ (if (pair? unusable)
+ (error "Imports not usable:" unusable)))
+ (imports->environment
+ (expand-parsed-imports parsed host-library-db)
+ host-library-db)))
+
+(define-automatic-property 'exporter '(exports environment)
+ #f
+ (lambda (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))))))
+\f
+;;;; Load
+
+#|
+(define (load db)
+ (for-each (lambda (parsed)
+ (load-library (syntax-library parsed db)
+ db))
+ parsed-libraries)
+ (if (pair? imports)
+ (let ((environment*
+ (imports->environment
+ (expand-import-sets imports db))))
+ (let loop ((exprs body) (value unspecific))
+ (if (pair? exprs)
+ (loop (cdr exprs)
+ (eval (car exprs) environment*))
+ value)))))
+
+(define (load-library library-name db)
+ (or (db 'get-loaded library-name #f)
+ (let ((syntaxed (db 'get-syntaxed library-name)))
+ (let ((environment
+ (imports->environment
+ (syntaxed-library-imports syntaxed)
+ db)))
+ (scode-eval (syntaxed-library-body syntaxed)
+ environment)
+ (let ((loaded
+ (make-loaded-library (syntaxed-library-name syntaxed)
+ (syntaxed-library-exports syntaxed)
+ environment)))
+ (db 'save-loaded! loaded)
+ loaded)))))
+|#
\ 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)
+ (done (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)
+ (done 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)))))
+
+ (define (done libs imports body)
+ (make-r7rs-source libs imports body (->namestring pathname)))
+
+ (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-record-type <r7rs-source>
+ (make-r7rs-source parsed-libraries imports body filename)
+ 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)))))
+\f
(define (parse-define-library-form form #!optional pathname)
(let ((directory
(if (default-object? pathname)
(loop decls
imports
exports
- (append (reverse (cdr decl)) contents)))))
- (make-parsed-library (car result)
- (reverse imports)
- (reverse exports)
- (reverse contents)
- (if (default-object? pathname)
- #f
- pathname))))))))
-
-(define-record-type <parsed-library>
- (make-parsed-library name imports exports contents pathname)
- parsed-library?
- (name parsed-library-name)
- (imports parsed-library-imports)
- (exports parsed-library-exports)
- (contents parsed-library-contents)
- (pathname parsed-library-pathname))
+ (cons decl contents)))))
+ (make-library (car result)
+ 'parsed-imports (reverse imports)
+ 'exports (reverse exports)
+ 'parsed-contents (reverse contents)
+ 'filename (if (default-object? pathname)
+ #f
+ (->namestring pathname)))))))))
(define (expand-parsed-decls parsed-decls directory)
(append-map (lambda (parsed-decl)
((cond-expand)
(expand-parsed-decls
(evaluate-cond-expand eq? parsed-decl)))
- ((include)
+ ((include include-ci)
(list
(cons (car parsed-decl)
(map (lambda (p)
- (list (merge-pathnames (car p) directory)
- (cadr p)))
+ (merge-pathnames p directory))
(cdr parsed-decl)))))
(else
(list parsed-decl))))
\f
(define include-parser
(object-parser
- (encapsulate (lambda (keyword . pathnames)
- (cons 'include
- (map (lambda (pathname)
- (list pathname keyword))
- pathnames)))
+ (encapsulate list
(list (alt (match include) (match include-ci))
(* (object pathname-parser))))))
(win (error (string-append "Unrecognized " description ":") object)
lose)))
+(define (parsed-import-library import)
+ (case (car import)
+ ((library) (cadr import))
+ ((only except prefix rename) (parsed-import-library (cadr import)))
+ (else (error "Unrecognized import:" import))))
+
(define (library-name? object)
(and (list? object)
(every (lambda (elt)
(exact-nonnegative-integer? elt)))
object)))
-(define (expand-parsed-contents contents)
- (append-map (lambda (directive)
- (case (car directive)
- ((include)
- (parameterize ((param:reader-fold-case? #f))
- (append-map read-file
- (cdr directive))))
- ((include-ci)
- (parameterize ((param:reader-fold-case? #t))
- (append-map read-file
- (cdr directive))))
- ((begin)
- (cdr directive))
- (else
- (error "Unknown content directive:" directive))))
- contents))
-
-(define (make-library-export from #!optional to)
- (guarantee symbol? from 'make-library-export)
- (if (default-object? to)
- (%make-library-export from from)
- (begin
- (guarantee symbol? to 'make-library-export)
- (%make-library-export from to))))
-
-(define-record-type <library-export>
- (%make-library-export from to)
- library-export?
- (from library-export-from)
- (to library-export-to))
-
-(define-print-method library-export?
- (standard-print-method 'library-export
- (lambda (export)
- (list (library-export-from export)
- (library-export-to export)))))
-
-(define (library-export=? e1 e2)
- (and (eq? (library-export-from e1)
- (library-export-from e2))
- (eq? (library-export-to e1)
- (library-export-to e2))))
\ No newline at end of file
+(define (library-name=? n1 n2)
+ (guarantee library-name? n1 'library-name=?)
+ (guarantee library-name? n2 'library-name=?)
+ (and (= (length n1) (length n2))
+ (every eqv? n1 n2)))
\ No newline at end of file
(declare (usual-integrations))
\f
(define (add-standard-libraries! db)
- (for-each (lambda (p)
- (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))
+ (register-libraries! (make-standard-libraries) db))
+
+(define (make-standard-libraries)
+ (map (lambda (p)
+ (let ((name (car p))
+ (exports (cdr p)))
+ (make-library name
+ 'parsed-imports '()
+ 'exports (map make-library-export exports)
+ 'parsed-contents '()
+ 'filename #f
+ 'environment system-global-environment)))
+ standard-libraries))
(define (check-standard-libraries!)
(for-each (lambda (p)
(runtime hash)
(runtime dynamic)
(runtime regular-sexpression)
+ (runtime library database)
;; Microcode data structures
(runtime history)
(runtime scode)
(files)
(parent (runtime)))
-(define-package (runtime library parser)
- (files "library-parser")
+(define-package (runtime library database)
+ (files "library-database")
(parent (runtime library))
(export (runtime library)
- expand-parsed-contents
+ define-automatic-property
+ host-library-db
+ library-db?
+ library-environment
+ library-exporter
+ library-export->list
library-export-from
library-export-to
library-export=?
library-export?
- library-name?
+ library-exports
+ library-filename
+ library-imports-from
+ library-import->list
+ library-import-from
+ library-import-from-library
+ library-import-to
+ library-import=?
+ library-import?
+ library-imports
+ library-name
+ library-parsed-contents
+ library-parsed-imports
+ library-syntaxed-contents
+ library?
+ list->library-export
+ list->library-import
+ make-library
+ make-library-db
make-library-export
- parse-define-library-form
- parse-import-form
- parse-import-set
- parsed-library-contents
- parsed-library-exports
- parsed-library-imports
- parsed-library-name
- parsed-library-pathname
- parsed-library?))
+ make-library-import
+ register-libraries!
+ register-library!
+ registered-libraries
+ registered-library
+ registered-library?))
-(define-package (runtime library database)
- (files "library-database")
+(define-package (runtime library parser)
+ (files "library-parser")
(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?
- 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))
+ library-name=?
+ library-name?
+ parsed-import-library
+ 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?
+ read-r7rs-source)
+ (export (runtime load)
+ read-r7rs-source))
(define-package (runtime library standard)
(files "library-standard")
(export (runtime library)
add-standard-libraries!
check-standard-libraries!
+ make-standard-libraries
standard-library-exports
standard-library-names))
(files "library-imports")
(parent (runtime library))
(export (runtime library)
- expand-import-sets
- library-import-from
- library-import-from-library
- library-import-to
- library-import=?
- library-import?
- make-library-import))
+ expand-parsed-imports
+ parsed-import-expandable?
+ parsed-imports-expandable?))
(define-package (runtime library loader)
(files "library-loader")
environment ;R7RS
)
(export (runtime library)
- compile-library
- expanded-imports->environment
- library-exporter
- load-library)
- (export (runtime load)
- read-r7rs-source))
\ No newline at end of file
+ imports->environment))
\ No newline at end of file
--- /dev/null
+(define-library (example grid)
+ (export make rows cols ref each
+ (rename put! set!))
+ (import (scheme base))
+ (begin
+ ;; Create an NxM grid.
+ (define (make n m)
+ (let ((grid (make-vector n)))
+ (do ((i 0 (+ i 1)))
+ ((= i n) grid)
+ (let ((v (make-vector m #f)))
+ (vector-set! grid i v)))))
+ (define (rows grid)
+ (vector-length grid))
+ (define (cols grid)
+ (vector-length (vector-ref grid 0)))
+ ;; Return #f if out of range.
+ (define (ref grid n m)
+ (and (< -1 n (rows grid))
+ (< -1 m (cols grid))
+ (vector-ref (vector-ref grid n) m)))
+ (define (put! grid n m v)
+ (vector-set! (vector-ref grid n) m v))
+ (define (each grid proc)
+ (do ((j 0 (+ j 1)))
+ ((= j (rows grid)))
+ (do ((k 0 (+ k 1)))
+ ((= k (cols grid)))
+ (proc j k (ref grid j k)))))))
+
+(define-library (example life)
+ (export life)
+ (import (except (scheme base) set!)
+ (scheme write)
+ (example grid))
+ (begin
+ (define (life-count grid i j)
+ (define (count i j)
+ (if (ref grid i j) 1 0))
+ (+ (count (- i 1) (- j 1))
+ (count (- i 1) j)
+ (count (- i 1) (+ j 1))
+ (count i (- j 1))
+ (count i (+ j 1))
+ (count (+ i 1) (- j 1))
+ (count (+ i 1) j)
+ (count (+ i 1) (+ j 1))))
+ (define (life-alive? grid i j)
+ (case (life-count grid i j)
+ ((3) #t)
+ ((2) (ref grid i j))
+ (else #f)))
+ (define (life-print grid)
+ (newline)
+ ;;(display "\x1B;[1H\x1B;[J") ; clear vt100
+ (each grid
+ (lambda (i j v)
+ (display (if v "*" "-"))
+ (when (= j (- (cols grid) 1))
+ (newline)))))
+ (define (life grid iterations)
+ (do ((i 0 (+ i 1))
+ (grid0 grid grid1)
+ (grid1 (make (rows grid) (cols grid))
+ grid0))
+ ((= i iterations))
+ (each grid0
+ (lambda (j k v)
+ (let ((a (life-alive? grid0 j k)))
+ (set! grid1 j k a))))
+ (life-print grid1)))))
+
+;; Main program.
+(import (scheme base)
+ (only (example life) life)
+ (rename (prefix (example grid) grid-)
+ (grid-make make-grid)))
+
+;; Initialize a grid with a glider.
+(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)
+
+;; Run for 80 iterations.
+(life grid 80)
\ No newline at end of file
(case (car import)
((only except prefix)
`(,(car import)
- (library ,(cadr import))
+ ,(convert-import (cadr import))
,@(cddr import)))
((rename)
`(,(car import)
- (library ,(cadr import))
+ ,(convert-import (cadr import))
,@(map (lambda (p)
(cons (car p) (cadr p)))
(cddr import))))
(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))))
+ (list
+ (cons (car content)
+ (map (lambda (path)
+ (merge-pathnames path test-directory))
+ (cdr content)))))
+ ((begin) (list content))
+ (else (error "Unknown content:" content))))
(define ex1-imports
'((foo mumble)
(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
+(define (read-dependencies)
+ (r7rs-source-parsed-libraries
+ (read-r7rs-source dependencies-filename)))
+
+(define dependencies-filename
+ (->namestring
+ (merge-pathnames "test-library-data/dependencies.scm"
+ test-directory)))
+
+(define r7rs-example-filename
+ (->namestring
+ (merge-pathnames "test-library-data/r7rs-example.scm"
+ test-directory)))
\ No newline at end of file
\f
(include "test-library-data/support-code.scm")
-(define-test 'expand-import-sets:ex1
+(define-test 'expand-parsed-imports: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?)
- (make-library-import '(foo mumble) 'make-foo-mumble)
- (make-library-import '(foo mumble) 'foo-mumble-a)
- (make-library-import '(foo mumble) 'foo-mumble-b)
- (make-library-import '(foo grumble)
- 'foo-grumble?
- 'grumble-foo-grumble?)
- (make-library-import '(foo grumble)
- 'make-foo-grumble
- 'grumble-make-foo-grumble)
- (make-library-import '(foo grumble)
- 'foo-grumble-a
- 'grumble-foo-grumble-a)
- (make-library-import '(foo grumble)
- 'foo-grumble-b
- 'grumble-foo-grumble-b)
- (make-library-import '(foo quux) 'foo-quux?)
- (make-library-import '(foo quux) 'foo-quux-a)
- (make-library-import '(foo quux) 'foo-quux-b)
- (make-library-import '(foo quux)
- 'make-foo-quux
- 'create-foo-quux)))))
\ No newline at end of file
+ (let ((library (parse-define-library-form ex1 test-pathname))
+ (db (make-library-db 'test)))
+ (register-library! library db)
+ (register-libraries! (read-dependencies) db)
+ (assert-lset= library-import=?
+ (library-imports library)
+ (list (make-library-import '(foo mumble) 'foo-mumble?)
+ (make-library-import '(foo mumble) 'make-foo-mumble)
+ (make-library-import '(foo mumble) 'foo-mumble-a)
+ (make-library-import '(foo mumble) 'foo-mumble-b)
+ (make-library-import '(foo grumble)
+ 'foo-grumble?
+ 'grumble-foo-grumble?)
+ (make-library-import '(foo grumble)
+ 'make-foo-grumble
+ 'grumble-make-foo-grumble)
+ (make-library-import '(foo grumble)
+ 'foo-grumble-a
+ 'grumble-foo-grumble-a)
+ (make-library-import '(foo grumble)
+ 'foo-grumble-b
+ 'grumble-foo-grumble-b)
+ (make-library-import '(foo quux) 'foo-quux?)
+ (make-library-import '(foo quux) 'foo-quux-a)
+ (make-library-import '(foo quux) 'foo-quux-b)
+ (make-library-import '(foo quux)
+ 'make-foo-quux
+ 'create-foo-quux))))))
\ No newline at end of file
(define-test 'parse-library:empty
(lambda ()
- (let ((parsed
+ (let ((library
(parse-define-library-form '(define-library (foo bar))
test-pathname)))
- (value-assert parsed-library?
- "parsed library"
- parsed)
- (assert-equal (parsed-library-name parsed)
+ (value-assert library? "parsed library" library)
+ (assert-equal (library-name library)
'(foo bar))
- (assert-null (parsed-library-exports parsed))
- (assert-null (parsed-library-imports parsed))
- (assert-null (parsed-library-contents parsed))
- (assert-equal (parsed-library-pathname parsed)
- test-pathname))))
+ (assert-null (library-parsed-imports library))
+ (assert-null (library-exports library))
+ (assert-null (library-parsed-contents library))
+ (assert-string= (library-filename library)
+ (->namestring test-pathname)))))
(define-test 'parse-library:ex1
(lambda ()
- (let ((parsed (parse-define-library-form ex1 test-pathname)))
- (assert-equal (parsed-library-name parsed)
+ (let ((library (parse-define-library-form ex1 test-pathname)))
+ (assert-equal (library-name library)
'(foo bar))
(assert-lset= equal?
- (parsed-library-imports parsed)
+ (library-parsed-imports library)
(map convert-import ex1-imports))
(assert-lset= library-export=?
- (parsed-library-exports parsed)
+ (library-exports library)
(map convert-export ex1-exports))
(assert-list= equal?
- (parsed-library-contents parsed)
+ (library-parsed-contents library)
(append-map convert-content ex1-contents))
- (assert-equal (parsed-library-pathname parsed)
- test-pathname))))
+ (assert-string= (library-filename library)
+ (->namestring test-pathname)))))
(define-test 'parse-library:ex2
(lambda ()
- (let ((parsed (parse-define-library-form ex2 test-pathname)))
- (assert-equal (parsed-library-name parsed)
+ (let ((library (parse-define-library-form ex2 test-pathname)))
+ (assert-equal (library-name library)
'(foo bar))
(assert-lset= equal?
- (parsed-library-imports parsed)
+ (library-parsed-imports library)
(map convert-import (append ex1-imports ex2-extra-imports)))
(assert-lset= library-export=?
- (parsed-library-exports parsed)
+ (library-exports library)
(map convert-export (append ex1-exports ex2-extra-exports)))
(assert-list= equal?
- (parsed-library-contents parsed)
+ (library-parsed-contents library)
(append-map convert-content
(append ex2-extra-contents ex1-contents)))
- (assert-equal (parsed-library-pathname parsed)
- test-pathname))))
\ No newline at end of file
+ (assert-string= (library-filename library)
+ (->namestring test-pathname)))))
+
+(define-test 'read-r7rs-source:dependencies
+ (lambda ()
+ (let ((source (read-r7rs-source dependencies-filename)))
+ (let ((libraries (r7rs-source-parsed-libraries source)))
+ (assert-true (list? libraries))
+ (assert-= (length libraries) 4)
+ (assert-list= equal?
+ (map library-name libraries)
+ '((foo mumble)
+ (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))))
+
+(define-test 'read-r7rs-source:r7rs-example
+ (lambda ()
+ (let ((source (read-r7rs-source r7rs-example-filename)))
+ (let ((libraries (r7rs-source-parsed-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
(declare (usual-integrations))
\f
+(include "test-library-data/support-code.scm")
+
(define-test 'check-standard-libraries!
(lambda ()
(check-standard-libraries!)))
+(define-test 'make-standard-libraries
+ (map (lambda (library)
+ (lambda ()
+ (check-standard-library library)))
+ (make-standard-libraries)))
+
(define-test 'add-standard-libraries!
- (let ((db (make-library-db)))
+ (let ((db (make-library-db 'test)))
(add-standard-libraries! db)
(map (lambda (name)
- (lambda ()
- (assert-true (db 'metadata? name))
- (assert-false (db 'compiled? name))
- (assert-true (db 'loaded? name))
- (let ((exports (standard-library-exports name)))
- (let ((metadata (db 'get-metadata name)))
- (assert-equal (library-metadata-name metadata) name)
- (assert-null (library-metadata-imports metadata))
- (assert-lset= eq?
- (library-metadata-exports metadata)
- exports)
- (assert-false (library-metadata-pathname metadata)))
- (let ((loaded (db 'get-loaded name)))
- (assert-equal (loaded-library-name loaded) name)
- (assert-lset= eq?
- (loaded-library-exports loaded)
- exports)
- (assert-eqv (loaded-library-environment loaded)
- system-global-environment)))))
- (standard-library-names))))
\ No newline at end of file
+ (let ((library (registered-library name db)))
+ (lambda ()
+ (check-standard-library library))))
+ (standard-library-names))))
+
+(define (check-standard-library library)
+ (let ((exports (standard-library-exports (library-name library))))
+ (assert-null (library-parsed-imports library))
+ (assert-lset= library-export=?
+ (library-exports library)
+ (map make-library-export exports))
+ (assert-null (library-parsed-contents library))
+ (assert-false (library-filename library))
+ (assert-eqv (library-environment library)
+ system-global-environment)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff