From 71cf6bfa4bc48acf4989c6a29859e615296a1f27 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 9 Jun 2018 20:51:54 -0700 Subject: [PATCH] Not-yet-complete implementation of R7RS libraries. --- src/runtime/library-database.scm | 40 ++++++- src/runtime/library-imports.scm | 142 ++++++++++++++++++++++++ src/runtime/library-loader.scm | 169 +++++++++++++++++++++++++++++ src/runtime/library-parser.scm | 81 ++++++++------ src/runtime/library-standard.scm | 32 ++++-- src/runtime/make.scm | 2 - src/runtime/runtime.pkg | 57 ++++++++-- src/runtime/syntax-environment.scm | 51 ++++++++- src/runtime/syntax.scm | 23 +++- 9 files changed, 533 insertions(+), 64 deletions(-) create mode 100644 src/runtime/library-imports.scm create mode 100644 src/runtime/library-loader.scm diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 7741ea368..6f3066601 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -30,6 +30,40 @@ USA. (declare (usual-integrations)) (define (make-library-db) + (let ((compiled (make-library-table)) + (loaded (make-library-table))) + + (define (compiled? name) + (compiled 'has? name)) + + (define (get-compiled name #!optional default-value) + (compiled 'get name default-value)) + + (define (save-compiled! library) + (compiled 'put! (compiled-library-name library) library)) + + (define (require-compiled names) + (let ((unknown (remove compiled? names))) + (if (pair? unknown) + (error "Can't resolve libraries:" unknown)))) + + (define (loaded? name) + (loaded 'has? name)) + + (define (get-loaded name #!optional default-value) + (loaded 'get name default-value)) + + (define (save-loaded! library) + (loaded 'put! (loaded-library-name library) library)) + + (bundle library-db? + compiled? get-compiled save-compiled! require-compiled + loaded? get-loaded save-loaded!))) + +(define library-db? + (make-bundle-predicate 'library-database)) + +(define (make-library-table) (let ((table (make-equal-hash-table))) (define (has? name) @@ -54,7 +88,7 @@ USA. (put! (car p) (cdr p))) alist*)) - (bundle library-db? has? get put! delete! get-alist put-alist!))) + (bundle library-table? has? get put! delete! get-alist put-alist!))) -(define library-db? - (make-bundle-predicate 'library-database)) \ No newline at end of file +(define library-table? + (make-bundle-predicate 'library-table)) \ No newline at end of file diff --git a/src/runtime/library-imports.scm b/src/runtime/library-imports.scm new file mode 100644 index 000000000..9298307f7 --- /dev/null +++ b/src/runtime/library-imports.scm @@ -0,0 +1,142 @@ +#| -*-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. + +|# + +;;;; R7RS libraries: imports +;;; package: (runtime library imports) + +(declare (usual-integrations)) + +(define (convert-import-sets import-sets library-db) + (library-db 'require-compiled (import-sets->libraries import-sets)) + (let ((converted-sets + (map (lambda (import-set) + (convert-import-set import-set library-db)) + import-sets))) + (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))) + +(define (import-sets->libraries import-sets) + (delete-duplicates (append-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 (find-intersections converted-sets) + (if (pair? converted-sets) + (let* ((links1 (car converted-sets)) + (names1 (map library-import-to links1))) + (append (filter-map (lambda (links2) + (and (intersecting-names? + names1 + (map library-import-to links2)) + (list links1 links2))) + (cdr converted-sets)) + (find-intersections converted-sets))) + '())) + +(define (intersecting-names? names1 names2) + (pair? (lset-intersection eq? names1 names2))) + +(define (unconvert-intersections intersections converted-sets imported-sets) + (let ((alist (map cons converted-sets imported-sets))) + (map (lambda (intersection) + (map (lambda (converted-set) + (cdr (assq converted-set alist))) + intersection)) + intersections))) + +;;; Returns a list of ( ) elements. +(define (convert-import-set import-set library-db) + (let ((converted-set + (let loop ((import-set import-set) (filter (lambda (name) name))) + (case (car import-set) + ((library) + (let ((library-name (cadr import-set))) + (filter-map (lambda (export) + (let* ((name (library-export-to export)) + (filtered (filter name))) + (and filtered + (make-library-import filtered + name + library-name)))) + (compiled-library-exports + (library-db 'get-compiled library-name))))) + ((only) + (loop (cadr import-set) + (let ((names (cddr import-set))) + (lambda (name) + (and (memq name names) + (filter name)))))) + ((except) + (loop (cadr import-set) + (let ((names (cddr import-set))) + (lambda (name) + (and (not (memq name names)) + (filter name)))))) + ((prefix) + (loop (cadr import-set) + (let ((prefix (caddr import-set))) + (lambda (name) + (filter (symbol prefix name)))))) + ((rename) + (loop (cadr import-set) + (let ((renames (cddr import-set))) + (lambda (name) + (filter + (let ((p (assq name renames))) + (if p + (cdr p) + name))))))) + (else + (error "Unrecognized import set:" import-set)))))) + (if (duplicate-names? (map library-import-to converted-set)) + (error "Import set has duplicate names:" import-set)) + converted-set)) + +(define (duplicate-names? names) + (and (pair? names) + (let loop ((names (sort names symbolenvironment imports library-db)) + (let ((exports-from (map library-export-from exports))) + (if (not (lset<= eq? exports-from (lset-union eq? bound free))) + (warn "Library export refers to unbound identifiers:" + (lset-difference eq? + exports-from + (lset-union eq? bound free))))) + (let ((imports-to (map library-import-to imports))) + (if (not (lset<= eq? free imports-to)) + (warn "Library has free references not provided by imports:" + (lset-difference eq? free imports-to)))) + body))) + +(define-record-type + (make-compiled-library name imports exports body) + compiled-library? + (name compiled-library-name) + (imports compiled-library-imports) + (exports compiled-library-exports) + (body compiled-library-body)) + +(define (compiled-library->scode library) + (make-scode-declaration + `(target-metadata + (library (name ,(compiled-library-name library)) + (imports ,(compiled-library-imports library)) + (exports ,(compiled-library-exports library)))) + (make-scode-quotation (compiled-library-body library)))) + +;;;; 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 + (converted-imports->environment + (compiled-library-imports compiled) + library-db))) + (scode-eval (compiled-library-body compiled) + environment) + (make-loaded-library (compiled-library-name compiled) + (compiled-library-exports compiled) + environment + library-db))))) + +(define (make-loaded-library name exports environment library-db) + (let ((library + (%make-loaded-library name + (map library-export-to exports) + (make-exporter exports environment) + environment))) + (library-db 'save-loaded! library) + library)) + +(define (make-exporter exports environment) + (let ((export-alist + (map (lambda (export) + (cons (library-export-to export) + (environment-safe-lookup environment + (library-export-from export)))) + exports))) + (lambda (name) + (let ((p (assq name export-alist))) + (if (not p) + (error "Not an exported name:" name)) + (cdr p))))) + +(define-record-type + (%make-loaded-library name environment exporter) + loaded-library? + (name loaded-library-name) + (exports loaded-library-exports) + (exporter loaded-library-exporter) + (environment loaded-library-environment)) + +(define (library-exporter library-name library-db) + (loaded-library-exporter (load-library library-name library-db))) + +(define (environment . import-sets) + (converted-imports->environment + (convert-import-sets (map parse-import-set import-sets)))) + +(define (converted-imports->environment imports library-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)) + (name (library-import-to import))) + (cond ((macro-reference-trap? value) + (environment-define-macro + env name + (macro-reference-trap-transformer value))) + ((unassigned-reference-trap? value) + ;; nothing to do + ) + (else + (environment-define env name value))))) + imports) + env)) \ No newline at end of file diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm index 94531da2e..26e42b41a 100644 --- a/src/runtime/library-parser.scm +++ b/src/runtime/library-parser.scm @@ -29,37 +29,41 @@ USA. (declare (usual-integrations)) -(define (parse-define-library-form form) - (let ((result (%parse-define-library form))) - (and result - (let loop - ((decls (expand-parsed-decls (cdr result))) - (exports '()) - (imports '()) - (contents '())) - (if (pair? decls) - (let ((decl (car decls)) - (decls (cdr decls))) - (case (car decl) - ((export) - (loop decls - (append (reverse (cdr decl)) exports) - imports - contents)) - ((import) - (loop decls - exports - (append (reverse (cdr decl)) imports) - contents)) - (else - (loop decls - exports - imports - (append (reverse (cdr decl)) contents))))) - (make-parsed-library (car result) - (reverse exports) - (reverse imports) - (reverse contents))))))) +(define (parse-define-library-form form #!optional pathname) + (let ((directory + (if (default-object? pathname) + (working-directory-pathname) + (directory-pathname pathname)))) + (let ((result (%parse-define-library form))) + (and result + (let loop + ((decls (expand-parsed-decls (cdr result) pathname)) + (exports '()) + (imports '()) + (contents '())) + (if (pair? decls) + (let ((decl (car decls)) + (decls (cdr decls))) + (case (car decl) + ((export) + (loop decls + (append (reverse (cdr decl)) exports) + imports + contents)) + ((import) + (loop decls + exports + (append (reverse (cdr decl)) imports) + contents)) + (else + (loop decls + exports + imports + (append (reverse (cdr decl)) contents))))) + (make-parsed-library (car result) + (reverse exports) + (reverse imports) + (reverse contents)))))))) (define-record-type (make-parsed-library name exports imports contents) @@ -69,17 +73,26 @@ USA. (imports parsed-library-imports) (contents parsed-library-contents)) -(define (expand-parsed-decls parsed-decls) +(define (expand-parsed-decls parsed-decls directory) (append-map (lambda (parsed-decl) (case (car parsed-decl) ((include-library-declarations) (append-map (lambda (pathname) - (expand-parsed-decls - (get-library-declarations pathname))) + (let ((pathname* + (merge-pathnames pathname directory))) + (expand-parsed-decls + (get-library-declarations pathname*) + (directory-pathname pathname*)))) (cdr parsed-decl))) ((cond-expand) (expand-parsed-decls (evaluate-cond-expand eq? parsed-decl))) + ((include include-ci) + (list + (cons (car parsed-decl) + (map (lambda (pathname) + (merge-pathnames pathname directory)) + (cdr parsed-decl))))) (else (list parsed-decl)))) parsed-decls)) diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index 2b437b02f..12b8fe77e 100644 --- a/src/runtime/library-standard.scm +++ b/src/runtime/library-standard.scm @@ -29,20 +29,28 @@ USA. (declare (usual-integrations)) -(define-deferred standard-libraries - (make-library-db)) +(define (add-standard-libraries library-db) + (for-each (lambda (p) + (make-loaded-library (car p) + (map (lambda (id) + (make-library-export id id)) + (cdr p)) + system-global-environment + library-db)) + standard-libraries)) (define (define-standard-library name exports) - (add-boot-init! - (lambda () - (standard-libraries 'put! - name - (make-parsed-library name - (map (lambda (id) - (cons id id)) - exports) - '() - '()))))) + (let ((p (assoc name standard-libraries))) + (if p + (set-cdr! p exports) + (begin + (set! standard-libraries + (cons (cons name exports) + standard-libraries)) + unspecific))) + name) + +(define standard-libraries '()) (define-standard-library '(scheme base) '(* diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 498452376..62e55bed9 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -531,8 +531,6 @@ USA. (runtime syntax rename) (runtime syntax top-level) (runtime syntax parser) - ;; R7RS Libraries - (runtime library standard) ;; REP Loops (runtime interrupt-handler) (runtime gc-statistics) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 368368723..144b7f43b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4486,6 +4486,8 @@ USA. syntax syntax* syntax-error) + (export (runtime library) + syntax-library-forms) (export (runtime syntax) biselect-cadr biselect-car @@ -4593,6 +4595,7 @@ USA. make-internal-senv make-keyword-senv make-partial-senv + make-sealed-senv reserve-identifier senv->runtime senv-top-level?)) @@ -5820,10 +5823,14 @@ USA. (export () world-report)) +(define-package (runtime library) + (files) + (parent (runtime))) + (define-package (runtime library parser) (files "library-parser") - (parent (runtime)) - (export (runtime) + (parent (runtime library)) + (export (runtime library) library-name? make-parsed-library parse-define-library-form @@ -5837,13 +5844,49 @@ USA. (define-package (runtime library database) (files "library-database") - (parent (runtime)) - (export (runtime) + (parent (runtime library)) + (export (runtime library) library-db? make-library-db)) (define-package (runtime library standard) (files "library-standard") - (parent (runtime)) - (export (runtime) - standard-libraries)) \ No newline at end of file + (parent (runtime library)) + (export (runtime library) + add-standard-libraries)) + +(define-package (runtime library imports) + (files "library-imports") + (parent (runtime library)) + (export (runtime library) + convert-import-sets + library-export-from + library-export-to + library-import-from + library-import-from-library + library-import-to + make-library-export)) + +(define-package (runtime library loader) + (files "library-loader") + (parent (runtime library)) + (export () + environment ;R7RS + ) + (export (runtime library) + compile-library + compiled-library->scode + compiled-library-body + compiled-library-exports + compiled-library-imports + compiled-library-name + compiled-library? + converted-imports->environment + library-exporter + load-library + loaded-library-environment + loaded-library-exporter + loaded-library-exports + loaded-library-name + loaded-library? + make-loaded-library)) \ No newline at end of file diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm index 4d7d0f3d3..1991bce5b 100644 --- a/src/runtime/syntax-environment.scm +++ b/src/runtime/syntax-environment.scm @@ -259,4 +259,53 @@ USA. (free-senv ,free-senv) (bound-senv ,bound-senv))) - (make-senv get-type get-runtime lookup store rename describe)))) \ No newline at end of file + (make-senv get-type get-runtime lookup store rename describe)))) + +;;; Sealed syntactic environments are used for libraries. A combination of +;;; top-level and internal syntactic environments, they gather all of the free +;;; references together so they can be captured by a lambda expression wrapped +;;; around the body of the library. + +(define (make-sealed-senv env) + (guarantee environment? env 'make-sealed-senv) + (let ((bound '()) + (free '())) + + (define (get-type) + 'sealed) + + (define (get-runtime) + env) + + (define (lookup identifier) + (cond ((or (assq identifier bound) + (assq identifier free)) + => cdr) + ((environment-lookup-macro env identifier)) + (else + ;; Capture free runtime references: + (let ((item (var-item identifier))) + (set! free (cons (cons identifier item) free)) + item)))) + + (define (store identifier item) + (cond ((assq identifier bound) + => (lambda (binding) + (set-cdr! binding item))) + ((assq identifier free) + (error "Can't define name; already free:" identifier)) + (else + (set! bound (cons (cons identifier item) bound)) + unspecific))) + + (define (rename identifier) + identifier) + + (define (describe) + `((bound ,bound) + (free ,free) + (env ,env))) + + (values (make-senv get-type get-runtime lookup store rename describe) + (lambda () (map car bound)) + (lambda () (map car free))))) \ No newline at end of file diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index b13ace974..31c2ecb4c 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -54,11 +54,24 @@ USA. (runtime-environment->syntactic environment)))) (with-identifier-renaming (lambda () - (compile-item - (body-item #f - (map-in-order (lambda (form) - (classify-form form senv (initial-hist form))) - forms))))))) + (syntax-internal forms senv))))) + +(define (syntax-library-forms forms env) + (guarantee list? forms 'syntax-library-forms) + (with-identifier-renaming + (lambda () + (receive (sealed get-bound get-free) (make-sealed-senv env) + (let ((result (syntax-internal forms sealed))) + (values result + (get-bound) + (get-free))))))) + +(define (syntax-internal forms senv) + (compile-item + (body-item #f + (map-in-order (lambda (form) + (classify-form form senv (initial-hist form))) + forms)))) ;;;; Classifier -- 2.25.1