(declare (usual-integrations))
\f
(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)
(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
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; R7RS libraries: imports
+;;; package: (runtime library imports)
+
+(declare (usual-integrations))
+\f
+(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)))
+\f
+;;; Returns a list of (<to-name> <from-name> <from-library>) 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 symbol<?)))
+ (and (pair? (cdr names))
+ (or (eq? (car names) (cadr names))
+ (loop (cdr names)))))))
+
+(define (make-library-import to from from-library) (list to from from-library))
+(define (library-import-to import) (car import))
+(define (library-import-from import) (cadr import))
+(define (library-import-from-library import) (caddr import))
+
+(define (make-library-export from to) (cons from to))
+(define (library-export-from export) (car export))
+(define (library-export-to export) (cdr export))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; R7RS libraries: loader
+;;; package: (runtime library loader)
+
+(declare (usual-integrations))
+\f
+;;;; Compile
+
+(define (compile-library form library-db)
+ (let ((library (parse-define-library-form form)))
+ (let ((imports
+ (convert-import-sets (parsed-library-imports library)
+ library-db)))
+ (make-compiled-library (parsed-library-name library)
+ imports
+ (parsed-library-exports library)
+ (compile-contents library library-db)))))
+
+(define (compile-contents library library-db)
+ (let ((imports (parsed-library-imports library))
+ (exports (parsed-library-exports library)))
+ (receive (body bound free)
+ (syntax-library-forms
+ (append-map (lambda (directive)
+ (case (car directive)
+ ((include)
+ (fluid-let ((param:reader-fold-case? #f))
+ (append-map (lambda (pathname)
+ (call-with-input-file pathname
+ read-file))
+ (cdr directive))))
+ ((include-ci)
+ (fluid-let ((param:reader-fold-case? #t))
+ (append-map (lambda (pathname)
+ (call-with-input-file pathname
+ read-file))
+ (cdr directive))))
+ ((begin)
+ (cdr directive))
+ (else
+ (error "Unknown content directive:" directive))))
+ (parsed-library-contents library))
+ (converted-imports->environment imports library-db))
+ (let ((exports-from (map library-export-from exports)))
+ (if (not (lset<= eq? exports-from (lset-union eq? bound free)))
+ (warn "Library export refers to unbound identifiers:"
+ (lset-difference eq?
+ exports-from
+ (lset-union eq? bound free)))))
+ (let ((imports-to (map library-import-to imports)))
+ (if (not (lset<= eq? free imports-to))
+ (warn "Library has free references not provided by imports:"
+ (lset-difference eq? free imports-to))))
+ body)))
+
+(define-record-type <compiled-library>
+ (make-compiled-library name imports exports body)
+ compiled-library?
+ (name compiled-library-name)
+ (imports compiled-library-imports)
+ (exports compiled-library-exports)
+ (body compiled-library-body))
+
+(define (compiled-library->scode library)
+ (make-scode-declaration
+ `(target-metadata
+ (library (name ,(compiled-library-name library))
+ (imports ,(compiled-library-imports library))
+ (exports ,(compiled-library-exports library))))
+ (make-scode-quotation (compiled-library-body library))))
+\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
+ (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 <loaded-library>
+ (%make-loaded-library name environment exporter)
+ loaded-library?
+ (name loaded-library-name)
+ (exports loaded-library-exports)
+ (exporter loaded-library-exporter)
+ (environment loaded-library-environment))
+
+(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
(declare (usual-integrations))
\f
-(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 <parsed-library>
(make-parsed-library name exports imports contents)
(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))
(declare (usual-integrations))
\f
-(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)
'(*
(runtime syntax rename)
(runtime syntax top-level)
(runtime syntax parser)
- ;; R7RS Libraries
- (runtime library standard)
;; REP Loops
(runtime interrupt-handler)
(runtime gc-statistics)
syntax
syntax*
syntax-error)
+ (export (runtime library)
+ syntax-library-forms)
(export (runtime syntax)
biselect-cadr
biselect-car
make-internal-senv
make-keyword-senv
make-partial-senv
+ make-sealed-senv
reserve-identifier
senv->runtime
senv-top-level?))
(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
(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
(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))))
+\f
+;;; 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
(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))))
\f
;;;; Classifier
projects / mit-scheme.git / commitdiff