~ chicken-core (chicken-5) 96bae4947b044b9ba06ad0c6383d7e267689ff6e
commit 96bae4947b044b9ba06ad0c6383d7e267689ff6e
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Fri Feb 5 10:33:09 2016 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:35 2016 +1300
Hook modules into new provide/require infrastructure
Each module now provides an identifier, based on its name, which serves
as an indicator that the module's implementation has been loaded. The
expansions of `import` et al. then check to see whether this requirement
has already been provided before attempting to load the module's library.
diff --git a/core.scm b/core.scm
index 10c405d5..d5cf54ed 100644
--- a/core.scm
+++ b/core.scm
@@ -139,7 +139,7 @@
; (##core#define-external-variable <name> <type> <bool> [<symbol>])
; (##core#check <exp>)
; (##core#require-for-syntax <exp> ...)
-; (##core#require <id> ...)
+; (##core#require <id> <id> ...)
; (##core#app <exp> {<exp>})
; (##core#define-syntax <symbol> <expr>)
; (##core#define-compiler-syntax <symbol> <expr>)
@@ -326,6 +326,7 @@
chicken.expand
chicken.foreign
chicken.format
+ chicken.internal
chicken.io
chicken.keyword
chicken.pretty-print)
@@ -670,24 +671,23 @@
((##core#require)
(walk
- (let loop ((ids (map strip-syntax (cdr x))))
+ (let loop ((ids (strip-syntax (cdr x)))
+ (exps '()))
(if (null? ids)
- '(##core#undefined)
- (let ((id (car ids)))
- (let-values (((exp lib type)
- (##sys#expand-require id #t used-units)))
+ (foldl (lambda (expr e)
+ `(##core#if ,e (##core#undefined) ,expr))
+ (car exps)
+ (cdr exps))
+ (let ((id (car ids))
+ (rest (cdr ids)))
+ (let-values (((exp found type)
+ (##sys#process-require id #t (null? rest) used-units)))
(unless (not type)
(##sys#hash-table-update!
- file-requirements
- type
+ file-requirements type
(cut lset-adjoin/eq? <> id)
(cut list id)))
- (when (not lib)
- (unless (##sys#find-extension
- (##sys#canonicalize-extension-path id 'require) #f)
- (warning
- (sprintf "extension `~A' is currently not installed" id))))
- `(##core#begin ,exp ,(loop (cdr ids)))))))
+ (if found exp (loop rest (cons exp exps)))))))
e se dest ldest h ln))
((##core#let)
@@ -924,8 +924,8 @@
((##core#module)
(let* ((name (strip-syntax (cadr x)))
- (import-lib (or (assq name import-libraries) all-import-libraries))
- (unit (and import-lib (or unit-name name)))
+ (lib (or unit-name name))
+ (req (module-requirement name))
(exports
(or (eq? #t (caddr x))
(map (lambda (exp)
@@ -947,7 +947,7 @@
'module "modules may not be nested" name))
(let-values (((body module-registration)
(parameterize ((##sys#current-module
- (##sys#register-module name unit exports))
+ (##sys#register-module name lib exports))
(##sys#current-environment '())
(##sys#macro-environment
##sys#initial-macro-environment)
@@ -964,27 +964,21 @@
(print-error-message ex (current-error-port))
(exit 1))
(##sys#finalize-module (##sys#current-module)))
- (cond (import-lib
- (when enable-module-registration
- (emit-import-lib name import-lib))
- ;; Remove from list to avoid error
- (when (pair? import-lib)
- (set! import-libraries
- (delete import-lib import-libraries)))
- (values
- (reverse xs)
- '((##core#undefined))))
+ (cond ((or (assq name import-libraries) all-import-libraries)
+ => (lambda (il)
+ (emit-import-lib name il)
+ ;; Remove from list to avoid error
+ (when (pair? il)
+ (set! import-libraries
+ (delete il import-libraries)))
+ (values (reverse xs) '((##core#undefined)))))
((not enable-module-registration)
- (values
- (reverse xs)
- '((##core#undefined))))
+ (values (reverse xs) '((##core#undefined))))
(else
(values
(reverse xs)
- (if standalone-executable
- '()
- (##sys#compiled-module-registration
- (##sys#current-module)))))))
+ (##sys#compiled-module-registration
+ (##sys#current-module))))))
(else
(loop
(cdr body)
@@ -997,6 +991,7 @@
(let ((body
(canonicalize-begin-body
(append
+ `((##core#provide ,req))
(parameterize ((##sys#current-module #f)
(##sys#macro-environment
(##sys#meta-macro-environment)))
diff --git a/eval.scm b/eval.scm
index 3ef9fdfb..1a37d9a6 100644
--- a/eval.scm
+++ b/eval.scm
@@ -677,6 +677,7 @@
(if (null? body)
(let ((xs (reverse xs)))
(##sys#finalize-module (##sys#current-module))
+ (##sys#provide (module-requirement name))
(lambda (v)
(let loop2 ((xs xs))
(if (null? xs)
@@ -713,11 +714,13 @@
[(##core#require)
(compile
- (let loop ((ids (map strip-syntax (cdr x))))
+ (let loop ((ids (strip-syntax (cdr x))))
(if (null? ids)
'(##core#undefined)
- (let-values (((exp _ _) (##sys#expand-require (car ids))))
- `(##core#begin ,exp ,(loop (cdr ids))))))
+ (let ((id (car ids))
+ (rest (cdr ids)))
+ (let-values (((exp _ _) (##sys#process-require id #f (null? rest))))
+ `(##core#if ,exp (##core#undefined) ,(loop rest))))))
e #f tf cntr se)]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
@@ -1279,10 +1282,10 @@
;; Given a library specification, returns three values:
;;
;; - an expression for loading the library, if required
-;; - a fixed-up library id if the library was found, #f otherwise
+;; - a library id if the library was found, #f otherwise
;; - a requirement type (e.g. 'dynamic) or #f if provided statically
;;
-(define (##sys#expand-require lib #!optional compiling? (static-units '()))
+(define (##sys#process-require lib #!optional compiling? dynamic? (static-units '()))
(let ((id (library-id lib)))
(cond
((assq id core-unit-requirements) =>
@@ -1297,6 +1300,8 @@
`(##core#declare (uses ,id))
`(##sys#load-library (##core#quote ,id) #f))
id #f))
+ ((not dynamic?)
+ (values `(##sys#provided? (##core#quote ,id)) #f #f))
((extension-information/internal id #f) =>
(lambda (info)
(let ((s (assq 'syntax info))
@@ -1304,14 +1309,15 @@
(rr (assq 'require-at-runtime info)))
(values
`(##core#begin
- ,@(if s `((##core#require-for-syntax ,id)) '())
+ ,@(if (not s)
+ '()
+ `((##core#require-for-syntax ,id)))
,@(if (or nr (and (not rr) s))
'()
- (begin
- `((##sys#load-extension
- ,@(map (lambda (id) `(##core#quote ,id))
- (cond (rr (cdr rr))
- (else (list id)))))))))
+ (map (lambda (id)
+ `(##sys#load-extension (##core#quote ,id)))
+ (cond (rr (cdr rr))
+ (else (list id))))))
id
(if s 'dynamic/syntax 'dynamic)))))
(else
diff --git a/expand.scm b/expand.scm
index 3499db73..7774f97a 100644
--- a/expand.scm
+++ b/expand.scm
@@ -933,21 +933,21 @@
(##sys#extend-macro-environment
'import-syntax '()
(##sys#er-transformer
- (cut ##sys#import <> <> <>
+ (cut ##sys#expand-import <> <> <>
##sys#current-environment ##sys#macro-environment
#f #f 'import-syntax)))
(##sys#extend-macro-environment
'import-syntax-for-syntax '()
(##sys#er-transformer
- (cut ##sys#import <> <> <>
+ (cut ##sys#expand-import <> <> <>
##sys#current-meta-environment ##sys#meta-macro-environment
#t #f 'import-syntax-for-syntax)))
(##sys#extend-macro-environment
'reexport '()
(##sys#er-transformer
- (cut ##sys#import <> <> <>
+ (cut ##sys#expand-import <> <> <>
##sys#current-environment ##sys#macro-environment
#f #t 'reexport)))
@@ -956,12 +956,17 @@
(##sys#er-transformer
(lambda (x r c)
`(##core#begin
- ,@(map (lambda (spec)
- (let-values (((name lib v s i) (##sys#expand-import spec r c 'import)))
- (##sys#finalize-import
- name v s i
- ##sys#current-environment ##sys#macro-environment #f #f 'import)
- (if (not lib) '(##core#undefined) `(##core#require ,lib))))
+ ,@(map (lambda (x)
+ (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import)))
+ (if (not spec)
+ (##sys#syntax-error-hook
+ 'import "cannot import from undefined module" name)
+ (##sys#import
+ spec v s i
+ ##sys#current-environment ##sys#macro-environment #f #f 'import))
+ (if (not lib)
+ '(##core#undefined)
+ `(##core#require ,(module-requirement name) ,lib))))
(cdr x))))))
(##sys#extend-macro-environment
@@ -1454,7 +1459,11 @@
'()
(##sys#er-transformer
(lambda (x r c)
- `(##core#require ,@(cdr x)))))
+ `(##core#begin
+ ,@(map (lambda (x)
+ (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import)))
+ `(##core#require ,(module-requirement name) ,lib)))
+ (cdr x))))))
(##sys#extend-macro-environment
'require-extension
diff --git a/internal.scm b/internal.scm
index b505586a..08f9fcb1 100644
--- a/internal.scm
+++ b/internal.scm
@@ -30,7 +30,8 @@
(fixnum))
(module chicken.internal
- (library-id valid-library-specifier? string->c-identifier)
+ (library-id valid-library-specifier?
+ module-requirement string->c-identifier)
(import scheme chicken)
@@ -89,4 +90,12 @@
((null? lst)
(##sys#intern-symbol str))))))
+
+;;; Requirement identifier for modules:
+
+(define (module-requirement id)
+ (##sys#string->symbol
+ (##sys#string-append (##sys#slot id 1) "#")))
+
+
) ; chicken.internal
diff --git a/modules.scm b/modules.scm
index 8dce32ef..c10af7d5 100644
--- a/modules.scm
+++ b/modules.scm
@@ -556,25 +556,21 @@
(let* ((mname (##sys#resolve-module-name lib loc))
(mod (##sys#find-module mname #f loc)))
(unless mod
- (let* ((il (##sys#find-extension
- (string-append (symbol->string mname) ".import")
- #t)))
- (cond (il (parameterize ((##sys#current-module #f)
- (##sys#current-environment '())
- (##sys#current-meta-environment
- (##sys#current-meta-environment))
- (##sys#macro-environment
- (##sys#meta-macro-environment)))
- (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
- (chicken.eval#load il)))
- (set! mod (##sys#find-module mname 'import)))
- (else
- (##sys#syntax-error-hook
- loc "cannot import from undefined module"
- mname)))))
+ (and-let* ((il (##sys#find-extension
+ (string-append (symbol->string mname) ".import")
+ #t)))
+ (parameterize ((##sys#current-module #f)
+ (##sys#current-environment '())
+ (##sys#current-meta-environment
+ (##sys#current-meta-environment))
+ (##sys#macro-environment
+ (##sys#meta-macro-environment)))
+ (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
+ (chicken.eval#load il)
+ (set! mod (##sys#find-module mname 'import))))))
mod))
-(define (##sys#expand-import x r c loc)
+(define (##sys#decompose-import x r c loc)
(let ((%only (r 'only))
(%rename (r 'rename))
(%except (r 'except))
@@ -587,121 +583,129 @@
((symbol? x) (##sys#symbol->string x))
((number? x) (number->string x))
(else (##sys#syntax-error-hook loc "invalid prefix" ))))
- (define (module-imports name)
- (let ((mod (find-module/import-library name loc)))
- (values (module-name mod)
- (module-library mod)
- (module-vexports mod)
- (module-sexports mod)
- (module-iexports mod))))
- (let loop ((x x))
- (cond ((symbol? x)
- (module-imports (chicken.expand#strip-syntax x)))
- ((not (pair? x))
- (##sys#syntax-error-hook loc "invalid import specification" x))
- (else
- (let ((head (car x)))
- (cond ((c %only head)
- (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
- (let-values (((form name impv imps impi) (loop (cadr x)))
- ((imports) (chicken.expand#strip-syntax (cddr x))))
- (let loop ((ids imports) (v '()) (s '()) (missing '()))
- (cond ((null? ids)
- (for-each
- (lambda (id)
- (warn "imported identifier doesn't exist" name id))
- missing)
- (values `(,head ,form ,@imports) name v s impi))
- ((assq (car ids) impv) =>
- (lambda (a)
- (loop (cdr ids) (cons a v) s missing)))
- ((assq (car ids) imps) =>
- (lambda (a)
- (loop (cdr ids) v (cons a s) missing)))
- (else
- (loop (cdr ids) v s (cons (car ids) missing)))))))
- ((c %except head)
- (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
- (let-values (((form name impv imps impi) (loop (cadr x)))
- ((imports) (chicken.expand#strip-syntax (cddr x))))
- (let loop ((impv impv) (v '()) (ids imports))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()) (ids ids))
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (warn "excluded identifier doesn't exist" name id))
- ids)
- (values `(,head ,form ,@imports) name v s impi))
- ((memq (caar imps) ids) =>
- (lambda (id)
- (loop (cdr imps) s (delete (car id) ids eq?))))
- (else
- (loop (cdr imps) (cons (car imps) s) ids)))))
- ((memq (caar impv) ids) =>
- (lambda (id)
- (loop (cdr impv) v (delete (car id) ids eq?))))
- (else
- (loop (cdr impv) (cons (car impv) v) ids))))))
- ((c %rename head)
- (##sys#check-syntax loc x '(_ _ . #((symbol symbol) 0)))
- (let-values (((form name impv imps impi) (loop (cadr x)))
- ((renames) (chicken.expand#strip-syntax (cddr x))))
- (let loop ((impv impv) (v '()) (ids renames))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()) (ids ids))
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (warn "renamed identifier doesn't exist" name id))
- (map car ids))
- (values `(,head ,form ,@renames) name v s impi))
- ((assq (caar imps) ids) =>
- (lambda (a)
- (loop (cdr imps)
- (cons (cons (cadr a) (cdar imps)) s)
- (delete a ids eq?))))
- (else
- (loop (cdr imps) (cons (car imps) s) ids)))))
- ((assq (caar impv) ids) =>
- (lambda (a)
- (loop (cdr impv)
- (cons (cons (cadr a) (cdar impv)) v)
- (delete a ids eq?))))
- (else
- (loop (cdr impv) (cons (car impv) v) ids))))))
- ((c %prefix head)
- (##sys#check-syntax loc x '(_ _ _))
- (let-values (((name lib impv imps impi) (loop (cadr x)))
- ((prefix) (chicken.expand#strip-syntax (caddr x))))
- (define (rename imp)
- (cons
- (##sys#string->symbol
- (##sys#string-append (tostr prefix) (##sys#symbol->string (car imp))))
- (cdr imp)))
- (values `(,head ,name ,prefix) lib (map rename impv) (map rename imps) impi)))
- (else
- (module-imports (chicken.expand#strip-syntax x))))))))))
-
-(define (##sys#import x r c import-env macro-env meta? reexp? loc)
+ (call-with-current-continuation
+ (lambda (k)
+ (define (module-imports name)
+ (let* ((id (library-id name))
+ (mod (find-module/import-library id loc)))
+ (if (not mod)
+ (k id id #f #f #f #f)
+ (values (module-name mod)
+ (module-library mod)
+ (module-name mod)
+ (module-vexports mod)
+ (module-sexports mod)
+ (module-iexports mod)))))
+ (let loop ((x x))
+ (cond ((symbol? x)
+ (module-imports (chicken.expand#strip-syntax x)))
+ ((not (pair? x))
+ (##sys#syntax-error-hook loc "invalid import specification" x))
+ (else
+ (let ((head (car x)))
+ (cond ((c %only head)
+ (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
+ (let-values (((name lib spec impv imps impi) (loop (cadr x)))
+ ((imports) (chicken.expand#strip-syntax (cddr x))))
+ (let loop ((ids imports) (v '()) (s '()) (missing '()))
+ (cond ((null? ids)
+ (for-each
+ (lambda (id)
+ (warn "imported identifier doesn't exist" spec id))
+ missing)
+ (values name lib `(,head ,spec ,@imports) v s impi))
+ ((assq (car ids) impv) =>
+ (lambda (a)
+ (loop (cdr ids) (cons a v) s missing)))
+ ((assq (car ids) imps) =>
+ (lambda (a)
+ (loop (cdr ids) v (cons a s) missing)))
+ (else
+ (loop (cdr ids) v s (cons (car ids) missing)))))))
+ ((c %except head)
+ (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
+ (let-values (((name lib spec impv imps impi) (loop (cadr x)))
+ ((imports) (chicken.expand#strip-syntax (cddr x))))
+ (let loop ((impv impv) (v '()) (ids imports))
+ (cond ((null? impv)
+ (let loop ((imps imps) (s '()) (ids ids))
+ (cond ((null? imps)
+ (for-each
+ (lambda (id)
+ (warn "excluded identifier doesn't exist" name id))
+ ids)
+ (values name lib `(,head ,spec ,@imports) v s impi))
+ ((memq (caar imps) ids) =>
+ (lambda (id)
+ (loop (cdr imps) s (delete (car id) ids eq?))))
+ (else
+ (loop (cdr imps) (cons (car imps) s) ids)))))
+ ((memq (caar impv) ids) =>
+ (lambda (id)
+ (loop (cdr impv) v (delete (car id) ids eq?))))
+ (else
+ (loop (cdr impv) (cons (car impv) v) ids))))))
+ ((c %rename head)
+ (##sys#check-syntax loc x '(_ _ . #((symbol symbol) 0)))
+ (let-values (((name lib spec impv imps impi) (loop (cadr x)))
+ ((renames) (chicken.expand#strip-syntax (cddr x))))
+ (let loop ((impv impv) (v '()) (ids renames))
+ (cond ((null? impv)
+ (let loop ((imps imps) (s '()) (ids ids))
+ (cond ((null? imps)
+ (for-each
+ (lambda (id)
+ (warn "renamed identifier doesn't exist" name id))
+ (map car ids))
+ (values name lib `(,head ,spec ,@renames) v s impi))
+ ((assq (caar imps) ids) =>
+ (lambda (a)
+ (loop (cdr imps)
+ (cons (cons (cadr a) (cdar imps)) s)
+ (delete a ids eq?))))
+ (else
+ (loop (cdr imps) (cons (car imps) s) ids)))))
+ ((assq (caar impv) ids) =>
+ (lambda (a)
+ (loop (cdr impv)
+ (cons (cons (cadr a) (cdar impv)) v)
+ (delete a ids eq?))))
+ (else
+ (loop (cdr impv) (cons (car impv) v) ids))))))
+ ((c %prefix head)
+ (##sys#check-syntax loc x '(_ _ _))
+ (let-values (((name lib spec impv imps impi) (loop (cadr x)))
+ ((prefix) (chicken.expand#strip-syntax (caddr x))))
+ (define (rename imp)
+ (cons
+ (##sys#string->symbol
+ (##sys#string-append (tostr prefix) (##sys#symbol->string (car imp))))
+ (cdr imp)))
+ (values name lib `(,head ,spec ,prefix) (map rename impv) (map rename imps) impi)))
+ (else
+ (module-imports (chicken.expand#strip-syntax x))))))))))))
+
+(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
(##sys#check-syntax loc x '(_ . #(_ 1)))
(for-each
- (lambda (spec)
- (let-values (((name _ vsv vss vsi) (##sys#expand-import spec r c loc)))
- (##sys#finalize-import name vsv vss vsi import-env macro-env meta? reexp? loc)))
+ (lambda (x)
+ (let-values (((name _ spec v s i) (##sys#decompose-import x r c loc)))
+ (if (not spec)
+ (##sys#syntax-error-hook loc "cannot import from undefined module" name x)
+ (##sys#import spec v s i import-env macro-env meta? reexp? loc))))
(cdr x))
'(##core#undefined))
-(define (##sys#finalize-import name vsv vss vsi import-env macro-env meta? reexp? loc)
+(define (##sys#import spec vsv vss vsi import-env macro-env meta? reexp? loc)
(let ((cm (##sys#current-module)))
(when cm ; save import form
(if meta?
(set-module-meta-import-forms!
cm
- (append (module-meta-import-forms cm) (list name)))
+ (append (module-meta-import-forms cm) (list spec)))
(set-module-import-forms!
cm
- (append (module-import-forms cm) (list name)))))
+ (append (module-import-forms cm) (list spec)))))
(dd `(IMPORT: ,loc))
(dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
(dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
@@ -1026,6 +1030,9 @@
(register-feature! 'module-environments)
(define (module-environment mname #!optional (ename mname))
- (let* ((mod (find-module/import-library mname 'module-environment))
- (saved (module-saved-environments mod)))
- (##sys#make-structure 'environment ename (car saved) #t)))
+ (let ((mod (find-module/import-library mname 'module-environment)))
+ (if (not mod)
+ (##sys#syntax-error-hook
+ 'module-environment "undefined module" mname)
+ (##sys#make-structure
+ 'environment ename (car (module-saved-environments mod)) #t))))
diff --git a/tests/import-library-test1.scm b/tests/import-library-test1.scm
index e79658bd..f0c51381 100644
--- a/tests/import-library-test1.scm
+++ b/tests/import-library-test1.scm
@@ -1,7 +1,3 @@
-(import (only (chicken eval) provide))
-
-(provide 'foo) ; XXX
-
(module foo (foo xcase)
(import (rename scheme (case xcase)))
(define-syntax foo
diff --git a/tests/test-chained-modules.scm b/tests/test-chained-modules.scm
index 728ea9cf..0e67445f 100644
--- a/tests/test-chained-modules.scm
+++ b/tests/test-chained-modules.scm
@@ -1,7 +1,3 @@
-(import (only (chicken eval) provide))
-
-(provide 'm1 'm2 'm3) ; XXX
-
(module m1 ((s1 f1))
(import scheme chicken)
(define (f1) (print "f1") 'f1)
Trap