From 4576f0b46adeb6a97c1426781cd22c038b83adda Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 5 Oct 2018 22:31:21 -0700 Subject: [PATCH] Major rewrite of library support. New design is organized around adding properties to a library as they are computed, coupled with "automatic" properties that can compute themselves from existing ones. Basic stuff all works, and I'm able to get the R7RS example running. --- src/runtime/library-database.scm | 365 ++++++++++++------ src/runtime/library-imports.scm | 81 ++-- src/runtime/library-loader.scm | 286 +++++++------- src/runtime/library-parser.scm | 156 ++++---- src/runtime/library-standard.scm | 25 +- src/runtime/make.scm | 1 + src/runtime/runtime.pkg | 103 ++--- .../test-library-data/r7rs-example.scm | 88 +++++ .../test-library-data/support-code.scm | 44 +-- tests/runtime/test-library-imports.scm | 57 +-- tests/runtime/test-library-parser.scm | 89 +++-- tests/runtime/test-library-standard.scm | 45 ++- 12 files changed, 795 insertions(+), 545 deletions(-) create mode 100644 tests/runtime/test-library-data/r7rs-example.scm diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 813c89b21..241b585f8 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -29,144 +29,265 @@ USA. (declare (usual-integrations)) -(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)) + +(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)) + +;;;; 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)))) + +;;;; 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 + (%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 + (%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)) -(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 exporter environment) - 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 +;;;; 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 diff --git a/src/runtime/library-imports.scm b/src/runtime/library-imports.scm index 4804c11f2..c9fdb4d3f 100644 --- a/src/runtime/library-imports.scm +++ b/src/runtime/library-imports.scm @@ -29,29 +29,32 @@ USA. (declare (usual-integrations)) -(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) @@ -77,21 +80,19 @@ USA. intersection)) intersections))) -;;; Returns a list of ( ) 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))) @@ -129,30 +130,4 @@ USA. (let loop ((names (sort names symbol - (%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 diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm index d819adb54..d28a7e83e 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -29,157 +29,81 @@ 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)))) +;;;; 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)) -(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 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 - -(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 @@ -191,4 +115,72 @@ USA. (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)))))) + +;;;; 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 diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm index 280690acd..abe351694 100644 --- a/src/runtime/library-parser.scm +++ b/src/runtime/library-parser.scm @@ -29,6 +29,73 @@ 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) + (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 + (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))))) + (define (parse-define-library-form form #!optional pathname) (let ((directory (if (default-object? pathname) @@ -59,23 +126,14 @@ USA. (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 - (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) @@ -91,12 +149,11 @@ USA. ((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)))) @@ -170,11 +227,7 @@ USA. (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)))))) @@ -247,6 +300,12 @@ USA. (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) @@ -254,45 +313,8 @@ USA. (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 - (%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 diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index 6d459017f..f15501806 100644 --- a/src/runtime/library-standard.scm +++ b/src/runtime/library-standard.scm @@ -30,18 +30,19 @@ USA. (declare (usual-integrations)) (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) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index ea07502c7..82c4cc10b 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -475,6 +475,7 @@ USA. (runtime hash) (runtime dynamic) (runtime regular-sexpression) + (runtime library database) ;; Microcode data structures (runtime history) (runtime scode) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 0bcfb7c1b..8b541309a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5833,52 +5833,65 @@ USA. (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") @@ -5886,6 +5899,7 @@ USA. (export (runtime library) add-standard-libraries! check-standard-libraries! + make-standard-libraries standard-library-exports standard-library-names)) @@ -5893,13 +5907,9 @@ USA. (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") @@ -5908,9 +5918,4 @@ USA. 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 diff --git a/tests/runtime/test-library-data/r7rs-example.scm b/tests/runtime/test-library-data/r7rs-example.scm new file mode 100644 index 000000000..37968cdbb --- /dev/null +++ b/tests/runtime/test-library-data/r7rs-example.scm @@ -0,0 +1,88 @@ +(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 diff --git a/tests/runtime/test-library-data/support-code.scm b/tests/runtime/test-library-data/support-code.scm index ca2973b50..d0db663fe 100644 --- a/tests/runtime/test-library-data/support-code.scm +++ b/tests/runtime/test-library-data/support-code.scm @@ -39,11 +39,11 @@ USA. (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)))) @@ -58,13 +58,13 @@ USA. (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) @@ -115,16 +115,16 @@ USA. (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 diff --git a/tests/runtime/test-library-imports.scm b/tests/runtime/test-library-imports.scm index caa56ee29..f9331152b 100644 --- a/tests/runtime/test-library-imports.scm +++ b/tests/runtime/test-library-imports.scm @@ -30,32 +30,33 @@ USA. (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 diff --git a/tests/runtime/test-library-parser.scm b/tests/runtime/test-library-parser.scm index 9f095f96d..6b94af3ff 100644 --- a/tests/runtime/test-library-parser.scm +++ b/tests/runtime/test-library-parser.scm @@ -32,51 +32,92 @@ USA. (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 diff --git a/tests/runtime/test-library-standard.scm b/tests/runtime/test-library-standard.scm index 9a1d7d7d2..f9fb3316c 100644 --- a/tests/runtime/test-library-standard.scm +++ b/tests/runtime/test-library-standard.scm @@ -28,31 +28,34 @@ USA. (declare (usual-integrations)) +(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 -- 2.25.1