(alist %library-alist)
(original-alist %library-original-alist))
+(define-print-method library?
+ (standard-print-method 'library
+ (lambda (library)
+ (let ((name (library-name library)))
+ (if name
+ (list name)
+ '())))))
+
+(define-pp-describer library?
+ (lambda (library)
+ (cons (list 'db (%library-db library))
+ (map (lambda (p)
+ (list (car p) (cdr p)))
+ (cdr (%library-alist library))))))
+
(define (alist->library name alist)
(%make-library name
#f
(parsed-contents ())
(filename #f)))
+(define (copy-library library)
+ (alist->library (library-name library)
+ (alist-copy (cdr (%library-original-alist library)))))
+
(define (library-registered? library)
(and (%library-db library) #t))
(let ((db (%library-db library)))
(if (not db) (error "Library not registered:" library))
db))
-
+\f
(define (library-has? key library)
(if (and (memq key properties-requiring-load)
(library-preregistered? library))
(define properties-requiring-load
'(contents))
-(define (copy-library library)
- (alist->library (library-name library)
- (alist-copy (cdr (%library-original-alist library)))))
-
-(define-print-method library?
- (standard-print-method 'library
- (lambda (library)
- (let ((name (library-name library)))
- (if name
- (list name)
- '())))))
-
-(define-pp-describer library?
- (lambda (library)
- (cons (list 'db (%library-db library))
- (map (lambda (p)
- (list (car p) (cdr p)))
- (cdr (%library-alist library))))))
-
(define (library-accessor key)
(lambda (library)
(library-get key library)))
(define library-contents (library-accessor 'contents))
(define library-environment (library-accessor 'environment))
(define library-eval-result (library-accessor 'eval-result))
-(define library-exports (library-accessor 'exports))
+(define library-export-groups (library-accessor 'export-groups))
(define library-filename (library-accessor 'filename))
(define library-free-names (library-accessor 'free-names))
(define library-imports (library-accessor 'imports))
(parameterize ((current-library-db (library-db library)))
(load (library-filename library))))
\f
+;;;; Export groups
+
+;;; An export group can be private, meaning that only the library specified in
+;;; library-name may import the group's exports. It can also be public, in
+;;; which case library-name is #f.
+
+(define-record-type <export-group>
+ (make-export-group library-name exports)
+ export-group?
+ (library-name export-group-library-name)
+ (exports export-group-exports))
+
+(define (library-exports library #!optional importing-library-name)
+ (let ((groups (library-export-groups library)))
+ (if (default-object? importing-library-name)
+ (let ((public
+ (find (lambda (group)
+ (not (export-group-library-name group)))
+ groups)))
+ (if public
+ (export-group-exports (car public))
+ '()))
+ (fold (lambda (group exports)
+ (let ((export-to (export-group-library-name group)))
+ (if (or (not export-to)
+ (library-name=? export-to importing-library-name))
+ (append (export-group-exports group) exports)
+ exports)))
+ '()
+ groups))))
+
+(define (export-group->list group)
+ (cons (export-group-library-name group)
+ (map library-ixport->list (export-group-exports group))))
+
+(define (list->export-group list)
+ (make-export-group (car list)
+ (map list->library-ixport (cdr list))))
+\f
;;;; Automatic properties
(define (define-automatic-property prop deps guard generator)
((nameset) (nameset-libraries (cdr export-spec) libraries))
(else libraries)))
(defines-libraries (library-get 'parsed-defines library) libraries)
- (cdr parsed-export)))
+ (cddr parsed-export)))
(define (nameset-libraries nameset libraries)
(if (pair? nameset)
imports))
(else
(error "Unrecognized import set:" import-set)))))
-
-(define (mit-expand-parsed-export parsed-export names library exports)
- (expand-inclusions (map (lambda (name)
- (make-library-ixport (library-name library) name))
- names)
- (cdr parsed-export)
- (library-db library)
- library
- exports))
\f
+(define (mit-expand-parsed-export parsed-export names library)
+ (make-export-group
+ (cadr parsed-export)
+ (expand-inclusions (map (lambda (name)
+ (make-library-ixport (library-name library) name))
+ names)
+ (cddr parsed-export)
+ (library-db library)
+ library
+ '())))
+
(define (expand-exclusions sources exclusions db library acc)
(let ((part (partition-ixclusions exclusions))
(name-matcher (make-name-matcher sources exclusions library db)))
name)))))))
(else
(error "Unrecognized import set:" import-set))))))
-
+\f
(define (r7rs-parsed-export-libraries parsed-export library libraries)
(declare (ignore parsed-export library))
libraries)
-(define (r7rs-expand-parsed-export parsed-export names library exports)
+(define (r7rs-expand-parsed-export parsed-export names library)
(declare (ignore names))
-
- (define (spec->export spec)
- (if (symbol? spec)
- (make-library-ixport (library-name library) spec)
- (case (car spec)
- ((rename)
- (make-library-ixport (library-name library)
- (cadr spec)
- (caddr spec)))
- (else
- (error "Unrecognized export spec:" spec)))))
-
- (fold (lambda (spec exports) (cons (spec->export spec) exports))
- exports
- (cdr parsed-export)))
\ No newline at end of file
+ (make-export-group
+ (cadr parsed-export)
+ (map (lambda (spec)
+ (if (symbol? spec)
+ (make-library-ixport (library-name library) spec)
+ (case (car spec)
+ ((rename)
+ (make-library-ixport (library-name library)
+ (cadr spec)
+ (caddr spec)))
+ (else
+ (error "Unrecognized export spec:" spec)))))
+ (cddr parsed-export))))
\ No newline at end of file
(else (error "Unknown parsed import:" parsed-import)))
parsed-import db library imports))
\f
-(define-automatic-property 'exports
+(define-automatic-property 'export-groups
'(parsed-exports bound-names imports library)
#f
(lambda (parsed-exports bound-names imports library)
library)
(let* ((imports-to (map library-ixport-to imports))
(names (lset-union eq? bound-names imports-to))
- (exports
- (fold (lambda (parsed-export exports)
- (expand-parsed-export parsed-export names library exports))
- '()
- parsed-exports)))
- (let ((missing
- (lset-difference eq?
- (map library-ixport-from exports)
- names)))
- (if (pair? missing)
- (warn "Library exports refer to unbound identifiers:" missing)))
- (check-dupes "exports"
- library-ixport-to
- (lambda (export froms)
- (lset-adjoin eq? froms (library-ixport-from export)))
- exports)
- (map (lambda (export)
- ;; If this is a re-export, export directly from the source.
- (let* ((export-from (library-ixport-from export))
- (import
- (find (lambda (import)
- (eq? (library-ixport-to import) export-from))
- imports)))
- (if import
- (make-library-ixport (library-ixport-from-library import)
- (library-ixport-from import)
- (library-ixport-to export))
- export)))
- exports))))
+ (groups
+ (map (lambda (parsed-export)
+ (expand-parsed-export parsed-export names library))
+ (merge-parsed-exports parsed-exports))))
+ (check-missing-exports groups names)
+ (check-dupes-of-export-groups groups)
+ (map (lambda (group)
+ (make-export-group (export-group-library-name group)
+ (map-re-exports (export-group-exports group)
+ imports)))
+ groups))))
+
+(define (expand-parsed-export parsed-export names library)
+ ((case (car parsed-export)
+ ((r7rs-export) r7rs-expand-parsed-export)
+ ((mit-export) mit-expand-parsed-export)
+ (else (error "Unknown parsed export:" parsed-export)))
+ parsed-export names library))
(define (parsed-export-libraries parsed-export library libraries)
((case (car parsed-export)
(else (error "Unknown parsed export:" parsed-export)))
parsed-export library libraries))
-(define (expand-parsed-export parsed-export names library exports)
- ((case (car parsed-export)
- ((r7rs-export) r7rs-expand-parsed-export)
- ((mit-export) mit-expand-parsed-export)
- (else (error "Unknown parsed export:" parsed-export)))
- parsed-export names library exports))
+(define (merge-parsed-exports parsed-exports)
+ (let ((tag (caar parsed-exports))
+ (amap (make-amap (make-equal-comparator) 'alist)))
+ (for-each (lambda (parsed-export)
+ (amap-update!/default amap
+ (cadr parsed-export)
+ (lambda (names)
+ (lset-union (cddr parsed-export) names))
+ '()))
+ parsed-exports)
+ (map (lambda (p) (cons tag p))
+ (amap->alist amap))))
+\f
+(define (check-missing-exports groups names)
+ (let ((missing
+ (fold (lambda (export-group missing)
+ (lset-union eq?
+ (lset-difference eq?
+ (map library-ixport-from
+ (export-group-exports export-group))
+ names)
+ missing))
+ '()
+ groups)))
+ (if (pair? missing)
+ (warn "Library exports refer to unbound identifiers:" missing))))
+
+(define (check-dupes-of-export-groups groups)
+ (let-values (((public private)
+ (partition (lambda (group)
+ (not (export-group-library-name group)))
+ groups)))
+ (let ((base-names (and (pair? public) (export-group-exports (car public)))))
+ (for-each (lambda (private)
+ (check-dupes "exports"
+ library-ixport-to
+ (lambda (export froms)
+ (lset-adjoin eq?
+ froms
+ (library-ixport-from export)))
+ (if public
+ (append (export-group-exports private)
+ base-names)
+ (export-group-exports private))))
+ private))))
+
+(define (map-re-exports exports)
+ (map (lambda (export)
+ ;; If this is a re-export, export directly from the source.
+ (let* ((export-from (library-ixport-from export))
+ (import
+ (find (lambda (import)
+ (eq? (library-ixport-to import) export-from))
+ imports)))
+ (if import
+ (make-library-ixport (library-ixport-from-library import)
+ (library-ixport-from import)
+ (library-ixport-to export))
+ export)))
+ exports))
\f
(define (check-libraries-exist folder items db library)
(let ((unusable
(remove (lambda (name)
(and (registered-library? name db)
- (library-has? 'exports (registered-library name db))))
+ (library-has? 'export-groups
+ (registered-library name db))))
(fold (lambda (item acc)
(folder item library acc))
'()
(pair? (cddr p)))
(hash-table->alist table))
(lambda (a b)
- (symbol<? (car a) (car b))))))
-
-(define (get-exports library db)
- (library-exports (registered-library library db)))
\ No newline at end of file
+ (symbol<? (car a) (car b))))))
\ No newline at end of file
(syntax-library-forms (expand-contents parsed-contents) env)))
(define-automatic-property 'imports-used
- '(imports exports free-names bound-names)
+ '(imports export-groups free-names bound-names name)
#f
- (lambda (imports exports free-names bound-names)
+ (lambda (imports export-groups free-names bound-names)
(let ((imports-to
(lset-difference eq?
(map library-ixport-to imports)
imports-to
(lset-union eq?
free-names
- (map library-ixport-from
- exports)))))
+ (all-exported-names groups)))))
(filter (lambda (import)
(memq (library-ixport-to import) used))
imports)))))
+(define (all-exported-names groups)
+ (fold (lambda (group names)
+ (lset-union eq?
+ (map library-ixport-from
+ (export-group-exports group))
+ names))
+ '()
+ groups))
+
(define (expand-contents contents)
(append-map (lambda (directive)
(case (car directive)
(and (registered-library? name db)
(library-has? 'environment (registered-library name db)))))
-(define (make-environment-from-imports imports db #!optional sealed?)
+(define (make-environment-from-imports imports db #!optional sealed?
+ importing-library-name)
(let ((env
((if sealed?
make-root-top-level-environment
make-top-level-environment)
(delete-duplicates (map library-ixport-to imports) eq?))))
- (add-imports-to-env! imports env db)
+ (add-imports-to-env! imports env db importing-library-name)
env))
-(define (add-imports-to-env! imports env db)
+(define (add-imports-to-env! imports env db #!optional importing-library-name)
(let ((grouped
(let ((table (make-strong-eq-hash-table)))
(for-each (lambda (import)
(environment-define env tname value))))))
other))))
-(define (library-import-source import db)
+(define (library-import-source import db importing-library-name)
(let ((name (library-ixport-from import))
(library (registered-library (library-ixport-from-library import) db)))
(let ((export
(find (lambda (export)
(eq? name (library-ixport-to export)))
- (library-exports library))))
+ (library-exports library importing-library-name))))
(if (not export)
(error "Not an exported name:" name))
(values (library-environment library)
(library-ixport-from export)))))
\f
-(define-automatic-property 'imports-environment '(imports db)
- (lambda (imports db)
+(define-automatic-property 'imports-environment '(imports db name)
+ (lambda (imports db name)
+ (declare (ignore name))
(every (lambda (import)
(environment-available? import db))
imports))
- make-environment-from-imports)
+ (lambda (imports db name)
+ (make-environment-from-imports imports db #t name)))
(define (environment . import-sets)
(let ((db (current-library-db)))
db
#f)))
+(define (scheme-report-environment version)
+ (if (not (eqv? version 5))
+ (error "Unsupported version:" version))
+ (environment '(scheme r5rs)))
+
+(define (null-environment version)
+ (if (not (eqv? version 5))
+ (error "Unsupported version:" version))
+ (environment '(only (scheme r5rs)
+ ... => _ and begin case cond define define-syntax delay do
+ else if lambda let let* let-syntax letrec letrec-syntax or
+ quasiquote quote set! syntax-rules)))
+
(define (repl-import . import-sets)
(let ((db (current-library-db)))
(add-imports-to-env! (import-sets->imports import-sets db)
(nearest-repl/environment)
db)))
-
+\f
(define (import-sets->imports import-sets db)
(parsed-imports->imports (map parse-import-set import-sets) db))
(for-each trace libraries)
(make-digraph (hash-table-keys table)
(lambda (library) (hash-table-ref table library)))))
-
-(define (scheme-report-environment version)
- (if (not (eqv? version 5))
- (error "Unsupported version:" version))
- (environment '(scheme r5rs)))
-
-(define (null-environment version)
- (if (not (eqv? version 5))
- (error "Unsupported version:" version))
- (environment '(only (scheme r5rs)
- ... => _ and begin case cond define define-syntax delay do
- else if lambda let let* let-syntax letrec letrec-syntax or
- quasiquote quote set! syntax-rules)))
\f
;;;; Evaluation
(let ((scode (fasload file)))
(if (r7rs-scode-file? scode)
(let ((libs (r7rs-scode-file-libraries scode)))
- (if (every scode-library-version-current? libs)
+ (if (every scode-library-version-usable? libs)
(succeed (let ((ns (->namestring file)))
(map (lambda (lib)
(scode-library->library lib ns))
(object-parser
(alt mit-define-parser
mit-export-parser
+ mit-export-to-parser
mit-import-parser
mit-cond-expand-parser
r7rs-include-parser
(object-parser
(encapsulate list
(list 'export
- (values 'mit-export)
+ (values 'mit-export #f)
+ (* (object mit-inclusion-parser))))))
+
+(define mit-export-to-parser
+ (object-parser
+ (encapsulate list
+ (list 'export-to
+ (values 'mit-export-to)
+ (match-if library-name?)
(* (object mit-inclusion-parser))))))
(define mit-import-parser
(declare (usual-integrations))
\f
-(define current-scode-library-version 2)
+(define current-scode-library-version 3)
+(define usable-scode-library-versions '(2 3))
(define (make-scode-library metadata contents)
(make-scode-declaration `((version ,current-scode-library-version)
(parse-declaration-text (scode-declaration-text object))
(scode-quotation? (scode-declaration-expression object))))
-(define (scode-library-version-current? library)
- (= (scode-library-version library) current-scode-library-version))
+(define (scode-library-version-usable? library)
+ (memv (scode-library-version library) usable-scode-library-versions))
(define (scode-library-version library)
((parse-declaration-text (scode-declaration-text library)) 'version))
(define (scode-library-imports-used library)
(map list->library-ixport (scode-library-property 'imports-used library)))
-(define (scode-library-exports library)
- (map list->library-ixport (scode-library-property 'exports library)))
+(define (scode-library-export-groups library)
+ (if (= 2 (scode-library-version library))
+ (make-export-group
+ #f
+ (map list->library-ixport (scode-library-property 'exports library)))
+ (map list->export-group (scode-library-property 'export-groups library))))
(define (singleton-list? object)
(and (pair? object)
(name ,(library-name library))
(imports ,@(map library-ixport->list (library-imports library)))
(imports-used ,@(map library-ixport->list (library-imports-used library)))
- (exports ,@(map library-ixport->list (library-exports library))))
+ (export-groups ,@(map export-group->list (library-export-groups library))))
(library-contents library)))
(define (scode-library->library library filename)
(make-library (scode-library-name library)
'imports (scode-library-imports library)
'imports-used (scode-library-imports-used library)
- 'exports (scode-library-exports library)
+ 'export-groups (scode-library-export-groups library)
'contents (scode-library-contents library)
'filename filename))
(parent (runtime library))
(export (runtime)
copy-library-db
+ export-group-exports
+ export-group-library-name
library-bound-names
library-contents
library-db
library-db?
library-environment
+ library-export-groups
library-exports
library-filename
library-free-names
(export (runtime library)
define-automatic-property
deregister-library!
+ export-group->list
library-eval-result
library-preregistered?
+ list->export-group
load-preregistered-library!
+ make-export-group
make-library
preregister-library!
register-libraries!
scode-library-imports-used
scode-library-name
scode-library-version
- scode-library-version-current?
+ scode-library-version-usable?
scode-library?)
(export (runtime library)
library->scode-library
projects / mit-scheme.git / commitdiff