~ chicken-core (chicken-5) 33bccc8b946a37e0ec35be37ff6aba7e152bdb39
commit 33bccc8b946a37e0ec35be37ff6aba7e152bdb39
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Oct 4 09:32:16 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Oct 4 09:32:16 2010 -0400
report location of unresolved refs in modules (only minimally tested)
diff --git a/compiler.scm b/compiler.scm
index 32c7fa66..c5323e39 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -441,14 +441,14 @@
(cadr x)
x) )
- (define (resolve-variable x0 e se dest ldest)
+ (define (resolve-variable x0 e se dest ldest h)
(let ((x (lookup x0 se)))
(d `(RESOLVE-VARIABLE: ,x0 ,x ,(map car se)))
(cond ((not (symbol? x)) x0) ; syntax?
[(and constants-used (##sys#hash-table-ref constant-table x))
- => (lambda (val) (walk (car val) e se dest ldest)) ]
+ => (lambda (val) (walk (car val) e se dest ldest h)) ]
[(and inline-table-used (##sys#hash-table-ref inline-table x))
- => (lambda (val) (walk val e se dest ldest)) ]
+ => (lambda (val) (walk val e se dest ldest h)) ]
[(assq x foreign-variables)
=> (lambda (fv)
(let* ([t (second fv)]
@@ -458,7 +458,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest)))]
+ e se dest ldest h)))]
[(assq x location-pointer-map)
=> (lambda (a)
(let* ([t (third a)]
@@ -468,9 +468,9 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest))) ]
+ e se dest ldest h))) ]
((##sys#get x '##core#primitive))
- ((not (memq x e)) (##sys#alias-global-hook x #f)) ; only if global
+ ((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
(define (eval/meta form)
@@ -505,13 +505,13 @@
(for-each pretty-print imps)
(print "\n;; END OF FILE"))))) ) )
- (define (walk x e se dest ldest)
+ (define (walk x e se dest ldest h)
(cond ((symbol? x)
(cond ((keyword? x) `(quote ,x))
((memq x unlikely-variables)
(warning
(sprintf "reference to variable `~s' possibly unintended" x) )))
- (resolve-variable x e se dest ldest))
+ (resolve-variable x e se dest ldest h))
((not-pair? x)
(if (constant? x)
`(quote ,x)
@@ -528,11 +528,11 @@
(name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
(xexpanded (##sys#expand x se compiler-syntax-enabled)))
(cond ((not (eq? x xexpanded))
- (walk xexpanded e se dest ldest))
+ (walk xexpanded e se dest ldest h))
[(and inline-table-used (##sys#hash-table-ref inline-table name))
=> (lambda (val)
- (walk (cons val (cdr x)) e se dest ldest)) ]
+ (walk (cons val (cdr x)) e se dest ldest h)) ]
[else
(when ln (update-line-number-database! xexpanded ln))
@@ -540,11 +540,11 @@
((##core#if)
`(if
- ,(walk (cadr x) e se #f #f)
- ,(walk (caddr x) e se #f #f)
+ ,(walk (cadr x) e se #f #f h)
+ ,(walk (caddr x) e se #f #f h)
,(if (null? (cdddr x))
'(##core#undefined)
- (walk (cadddr x) e se #f #f) ) ) )
+ (walk (cadddr x) e se #f #f h) ) ) )
((##core#syntax ##core#quote)
`(quote ,(##sys#strip-syntax (cadr x))))
@@ -552,7 +552,7 @@
((##core#check)
(if unsafe
''#t
- (walk (cadr x) e se dest ldest) ) )
+ (walk (cadr x) e se dest ldest h) ) )
((##core#immutable)
(let ((c (cadadr x)))
@@ -573,7 +573,7 @@
((##core#inline_loc_ref)
`(##core#inline_loc_ref
,(##sys#strip-syntax (cadr x))
- ,(walk (caddr x) e se dest ldest)))
+ ,(walk (caddr x) e se dest ldes ht)))
((##core#require-for-syntax)
(let ([ids (map eval (cdr x))])
@@ -604,7 +604,7 @@
(warning
(sprintf "extension `~A' is currently not installed" id)))
`(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
- e se dest ldest) ) )
+ e se dest ldest h) ) )
((##core#let)
(let* ((bindings (cadr x))
@@ -614,12 +614,12 @@
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
- (list alias (walk (cadr b) e se (car b) #t)) )
+ (list alias (walk (cadr b) e se (car b) #t h)) )
aliases bindings)
,(walk (##sys#canonicalize-body
(cddr x) se2 compiler-syntax-enabled)
(append aliases e)
- se2 dest ldest) ) ) )
+ se2 dest ldest h) ) ) )
((##core#letrec)
(let ((bindings (cadr x))
@@ -633,7 +633,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e se dest ldest)))
+ e se dest ldest h)))
((##core#lambda)
(let ((llist (cadr x))
@@ -650,7 +650,7 @@
(se2 (##sys#extend-se se vars aliases))
(body0 (##sys#canonicalize-body
obody se2 compiler-syntax-enabled))
- (body (walk body0 (append aliases e) se2 #f #f))
+ (body (walk body0 (append aliases e) se2 #f #f dest))
(llist2
(build-lambda-list
aliases argc
@@ -669,7 +669,7 @@
(expand-profile-lambda
(if (memq dest e) ; should normally not be the case
e
- (##sys#alias-global-hook dest #f))
+ (##sys#alias-global-hook dest #f #f))
llist2 body) )
(else l)))))))
@@ -686,7 +686,7 @@
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
e se2
- dest ldest) ) )
+ dest ldest h) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -703,7 +703,7 @@
ms)
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
- e se2 dest ldest)))
+ e se2 dest ldest h)))
((##core#define-syntax)
(##sys#check-syntax
@@ -729,7 +729,7 @@
(##sys#current-environment)
(##sys#er-transformer ,body)) ;*** possibly wrong se?
'(##core#undefined) )
- e se dest ldest)) )
+ e se dest ldest h)) )
((##core#define-compiler-syntax)
(let* ((var (cadr x))
@@ -756,7 +756,7 @@
(##sys#er-transformer ,body)
(##sys#current-environment))))
'(##core#undefined) )
- e se dest ldest)))
+ e se dest ldest h)))
((##core#let-compiler-syntax)
(let ((bs (map
@@ -779,7 +779,7 @@
(walk
(##sys#canonicalize-body
(cddr x) se compiler-syntax-enabled)
- e se dest ldest) )
+ e se dest ldest h) )
(lambda ()
(for-each
(lambda (b)
@@ -793,7 +793,7 @@
`(##core#begin
,@(fluid-let ((##sys#default-read-info-hook read-info-hook))
(##sys#include-forms-from-file (cadr x))))
- e se dest ldest))
+ e se dest ldest h))
((##core#module)
(let* ((x (##sys#strip-syntax x))
@@ -856,7 +856,7 @@
(car body)
e ;?
(##sys#current-environment)
- #f #f)
+ #f #f h)
xs))))))))
(let ((body
(canonicalize-begin-body
@@ -868,7 +868,7 @@
(walk
x
e ;?
- (##sys#current-meta-environment) #f #f) )
+ (##sys#current-meta-environment) #f #f h) )
mreg))
body))))
(do ((cs compiler-syntax (cdr cs)))
@@ -886,7 +886,7 @@
(walk
(##sys#canonicalize-body obody se2 compiler-syntax-enabled)
(append aliases e)
- se2 #f #f) ] )
+ se2 #f #f dest) ] )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
@@ -908,7 +908,7 @@
(##core#inline_update
(,(third fv) ,type)
,(foreign-type-check tmp type) ) )
- e se #f #f))))
+ e se #f #f h))))
((assq var location-pointer-map)
=> (lambda (a)
(let* ([type (third a)]
@@ -919,11 +919,11 @@
(,type)
,(second a)
,(foreign-type-check tmp type) ) )
- e se #f #f))))
+ e se #f #f h))))
(else
(unless (memq var e) ; global?
(set! var (or (##sys#get var '##core#primitive)
- (##sys#alias-global-hook var #t)))
+ (##sys#alias-global-hook var #t dest)))
(when safe-globals-flag
(mark-variable var '##compiler#always-bound-to-procedure)
(mark-variable var '##compiler#always-bound)))
@@ -938,29 +938,29 @@
(##sys#notice "assignment to imported value binding" var)))
(when (keyword? var)
(warning (sprintf "assignment to keyword `~S'" var) ))
- `(set! ,var ,(walk val e se var0 (memq var e)))))))
+ `(set! ,var ,(walk val e se var0 (memq var e) h))))))
((##core#inline)
- `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se)))
+ `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h)))
((##core#inline_allocate)
`(##core#inline_allocate
,(map (cut unquotify <> se) (second x))
- ,@(mapwalk (cddr x) e se)))
+ ,@(mapwalk (cddr x) e se h)))
((##core#inline_update)
- `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f)) )
+ `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h)) )
((##core#inline_loc_update)
`(##core#inline_loc_update
,(cadr x)
- ,(walk (caddr x) e se #f #f)
- ,(walk (cadddr x) e se #f #f)) )
+ ,(walk (caddr x) e se #f #f h)
+ ,(walk (cadddr x) e se #f #f h)) )
((##core#compiletimetoo ##core#elaborationtimetoo)
(let ((exp (cadr x)))
(eval/meta exp)
- (walk exp e se dest #f) ) )
+ (walk exp e se dest #f h) ) )
((##core#compiletimeonly ##core#elaborationtimeonly)
(eval/meta (cadr x))
@@ -973,24 +973,24 @@
(let ([x (car xs)]
[r (cdr xs)] )
(if (null? r)
- (list (walk x e se dest #f))
- (cons (walk x e se #f #f) (fold r)) ) ) ) )
+ (list (walk x e se dest #f h))
+ (cons (walk x e se #f #f h) (fold r)) ) ) ) )
'(##core#undefined) ) )
((##core#foreign-lambda)
- (walk (expand-foreign-lambda x #f) e se dest ldest) )
+ (walk (expand-foreign-lambda x #f) e se dest ldest h) )
((##core#foreign-safe-lambda)
- (walk (expand-foreign-lambda x #t) e se dest ldest) )
+ (walk (expand-foreign-lambda x #t) e se dest ldest h) )
((##core#foreign-lambda*)
- (walk (expand-foreign-lambda* x #f) e se dest ldest) )
+ (walk (expand-foreign-lambda* x #f) e se dest ldest h) )
((##core#foreign-safe-lambda*)
- (walk (expand-foreign-lambda* x #t) e se dest ldest) )
+ (walk (expand-foreign-lambda* x #t) e se dest ldest h) )
((##core#foreign-primitive)
- (walk (expand-foreign-primitive x) e se dest ldest) )
+ (walk (expand-foreign-primitive x) e se dest ldest h) )
((##core#define-foreign-variable)
(let* ([var (##sys#strip-syntax (second x))]
@@ -1024,7 +1024,7 @@
(define
,ret
,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
- e se dest ldest) ) ]
+ e se dest ldest h) ) ]
[else
(##sys#hash-table-set! foreign-type-table name type)
'(##core#undefined) ] ) ) )
@@ -1067,7 +1067,7 @@
'() )
,(if init (fifth x) (fourth x)) ) )
e (alist-cons var alias se)
- dest ldest) ) )
+ dest ldest h) ) )
((##core#define-inline)
(let* ((name (second x))
@@ -1099,7 +1099,7 @@
(hide-variable var)
(mark-variable var '##compiler#constant)
(mark-variable var '##compiler#always-bound)
- (walk `(define ,var ',val) e se #f #f) ) ] ) ) )
+ (walk `(define ,var ',val) e se #f #f h) ) ] ) ) )
((##core#declare)
(walk
@@ -1107,7 +1107,7 @@
,@(map (lambda (d)
(process-declaration d se))
(cdr x) ) )
- e '() #f #f) )
+ e '() #f #f h) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1127,7 +1127,7 @@
"non-matching or invalid argument list to foreign callback-wrapper"
vars atypes) )
`(##core#foreign-callback-wrapper
- ,@(mapwalk args e se)
+ ,@(mapwalk args e se h)
,(walk `(##core#lambda
,vars
(##core#let
@@ -1182,7 +1182,7 @@
(##sys#make-c-string r ',name)) ) ) )
(else (cddr lam)) ) )
rtype) ) )
- e se #f #f) ) ) ) )
+ e se #f #f h) ) ) ) )
((##core#location)
(let ([sym (cadr x)])
@@ -1191,22 +1191,23 @@
=> (lambda (a)
(walk
`(##sys#make-locative ,(second a) 0 #f 'location)
- e se #f #f) ) ]
+ e se #f #f h) ) ]
[(assq sym external-to-pointer)
- => (lambda (a) (walk (cdr a) e se #f #f)) ]
+ => (lambda (a) (walk (cdr a) e se #f #f h)) ]
[(memq sym callback-names)
`(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
[else
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f) ] )
+ e se #f #f h) ] )
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f) ) ) )
+ e se #f #f h) ) ) )
(else
- (let* ((x2 (fluid-let ((##sys#syntax-context (cons name ##sys#syntax-context)))
- (mapwalk x e se)))
+ (let* ((x2 (fluid-let ((##sys#syntax-context
+ (cons name ##sys#syntax-context)))
+ (mapwalk x e se h)))
(head2 (car x2))
(old (##sys#hash-table-ref line-number-database-2 head2)) )
(when ln
@@ -1222,7 +1223,7 @@
((constant? (car x))
(emit-syntax-trace-info x #f)
(warning "literal in operator position" x)
- (mapwalk x e se) )
+ (mapwalk x e se h) )
(else
(emit-syntax-trace-info x #f)
@@ -1231,10 +1232,10 @@
`(##core#let
((,tmp ,(car x)))
(,tmp ,@(cdr x)))
- e se dest ldest)))))
+ e se dest ldest h)))))
- (define (mapwalk xs e se)
- (map (lambda (x) (walk x e se #f #f)) xs) )
+ (define (mapwalk xs e se h)
+ (map (lambda (x) (walk x e se #f #f h)) xs) )
(when (memq 'c debugging-chicken) (newline) (pretty-print exp))
(##sys#clear-trace-buffer)
@@ -1247,7 +1248,7 @@
,(begin
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
- '() (##sys#current-environment) #f #f) ) )
+ '() (##sys#current-environment) #f #f #f) ) )
(define (process-declaration spec se) ; se unused in the moment
@@ -1263,7 +1264,7 @@
(define (globalize sym)
(if (symbol? sym)
(let loop ((se se)) ; ignores syntax bindings
- (cond ((null? se) (##sys#alias-global-hook sym #f))
+ (cond ((null? se) (##sys#alias-global-hook sym #f #f)) ;XXX could hint at decl (3rd arg)
((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
(else (loop (cdr se)))))
sym))
diff --git a/eval.scm b/eval.scm
index 98564138..0bbc84cb 100644
--- a/eval.scm
+++ b/eval.scm
@@ -253,7 +253,7 @@
(receive (i j) (lookup x e se)
(cond [(not i)
(let ((var (if (not (assq x se)) ; global?
- (##sys#alias-global-hook j #f)
+ (##sys#alias-global-hook j #f cntr)
(or (##sys#get j '##core#primitive) j))))
(if ##sys#eval-environment
(let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
@@ -367,7 +367,7 @@
(and-let* ((a (assq var (##sys#current-environment)))
((symbol? (cdr a))))
(##sys#notice "assignment to imported value binding" var)))
- (let ((var (##sys#alias-global-hook j #t)))
+ (let ((var (##sys#alias-global-hook j #t cntr)))
(if ##sys#eval-environment
(let ([loc (##sys#hash-table-location
##sys#eval-environment
diff --git a/expand.scm b/expand.scm
index a37d1ce3..062207f3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -95,7 +95,7 @@
(getp x '##core#macro-alias) ) ) )
(cond ((getp x '##core#real-name))
((and alias (not (assq x se)))
- (##sys#alias-global-hook x #f))
+ (##sys#alias-global-hook x #f #f))
((not x2) x)
((pair? x2) x)
(else x2))))
@@ -273,12 +273,13 @@
"#"
(##sys#slot sym 1) ) ) )
-(define (##sys#alias-global-hook sym assign)
+(define (##sys#alias-global-hook sym assign where)
(define (mrename sym)
(cond ((##sys#current-module) =>
(lambda (mod)
(dm "(ALIAS) global alias " sym " in " (module-name mod))
- (unless assign (##sys#register-undefined sym mod))
+ (unless assign
+ (##sys#register-undefined sym mod where))
(##sys#module-rename sym (module-name mod))))
(else sym)))
(cond ((##sys#qualified-symbol? sym) sym)
@@ -1590,7 +1591,7 @@
(defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...) - *exported* value definitions
(exist-list module-exist-list set-module-exist-list!) ; (SYMBOL ...) - only for checking refs to undef'd
(defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
- (undefined-list module-undefined-list set-module-undefined-list!) ; (SYMBOL ...)
+ (undefined-list module-undefined-list set-module-undefined-list!) ; ((SYMBOL WHERE1 ...) ...)
(import-forms module-import-forms set-module-import-forms!) ; (SPEC ...)
(meta-import-forms module-meta-import-forms set-module-meta-import-forms!) ; (SPEC ...)
(meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
@@ -1633,8 +1634,8 @@
(##sys#toplevel-definition-hook ; in compiler, hides unexported bindings
(##sys#module-rename sym (module-name mod))
mod exp #f)
- (when (memq sym ulist)
- (set-module-undefined-list! mod (##sys#delq sym ulist)))
+ (and-let* ((a (assq sym ulist)))
+ (set-module-undefined-list! mod (##sys#delq a ulist)))
(check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
(set-module-exist-list! mod (cons sym (module-exist-list mod)))
(when exp
@@ -1650,8 +1651,8 @@
(##sys#find-export sym mod #t)))
(ulist (module-undefined-list mod))
(mname (module-name mod)))
- (when (memq sym ulist)
- (##sys#warn "use of syntax precedes definition" sym))
+ (when (assq sym ulist)
+ (##sys#warn "use of syntax precedes definition" sym)) ;XXX could report locations
(check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
(dm "defined syntax: " sym)
(when exp
@@ -1663,11 +1664,17 @@
mod
(cons (cons sym val) (module-defined-syntax-list mod))))))
-(define (##sys#register-undefined sym mod)
+(define (##sys#register-undefined sym mod where)
(when mod
(let ((ul (module-undefined-list mod)))
- (unless (memq sym ul)
- (set-module-undefined-list! mod (cons sym ul))))))
+ (cond ((assq sym ul) =>
+ (lambda (a)
+ (when (and where (not (memq where (cdr a))))
+ (set-cdr! a (cons where (cdr a))))))
+ (else
+ (set-module-undefined-list!
+ mod
+ (cons (cons sym (if where (list where) '())) ul)))))))
(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
(let ((mod (make-module name explist vexports sexports)))
@@ -1860,99 +1867,113 @@
(loop (cdr xl))))
(else (loop (cdr xl)))))))
-(define (##sys#finalize-module mod)
- (let* ((explist (module-export-list mod))
- (name (module-name mod))
- (dlist (module-defined-list mod))
- (elist (module-exist-list mod))
- (missing #f)
- (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
- (module-defined-syntax-list mod)))
- (sexports
- (if (eq? #t explist)
- sdlist
- (let loop ((me (##sys#macro-environment)))
- (cond ((null? me) '())
- ((##sys#find-export (caar me) mod #f)
- (cons (car me) (loop (cdr me))))
- (else (loop (cdr me)))))))
- (vexports
- (let loop ((xl (if (eq? #t explist) elist explist)))
- (if (null? xl)
- '()
- (let* ((h (car xl))
- (id (if (symbol? h) h (car h))))
- (if (assq id sexports)
- (loop (cdr xl))
- (cons
- (cons
- id
- (let ((def (assq id dlist)))
- (if (and def (symbol? (cdr def)))
- (cdr def)
- (let ((a (assq id (##sys#current-environment))))
- (cond ((and a (symbol? (cdr a)))
- (dm "reexporting: " id " -> " (cdr a))
- (cdr a))
- ((not def)
- (set! missing #t)
- (##sys#warn
- (string-append
- "exported identifier of module `"
- (symbol->string name)
- "' has not been defined")
- id)
- #f)
- (else (##sys#module-rename id name)))))))
- (loop (cdr xl)))))))))
- (for-each
- (lambda (u)
- (unless (memq u elist)
- (set! missing #t)
- (##sys#warn "reference to possibly unbound identifier" u)
- (and-let* ((a (getp u '##core#db)))
- (if (= 1 (length a))
- (##sys#warn
- (string-append
- " suggesting: `(import " (symbol->string (cadar a))
- ")'"))
- (##sys#warn
- (string-append
- " suggesting one of:\n"
- (let loop ((lst a))
- (if (null? lst)
- ""
- (string-append
- "Warning: (import " (symbol->string (cadar lst)) ")\n"
- (loop (cdr lst)))))))))))
- (module-undefined-list mod))
- (when missing
- (##sys#error "module unresolved" name))
- (let* ((iexports
- (map (lambda (exp)
- (cond ((symbol? (cdr exp)) exp)
- ((assq (car exp) (##sys#macro-environment)))
- (else (##sys#error "(internal) indirect export not found" (car exp)))) )
- (module-indirect-exports mod)))
- (new-se (merge-se
- (##sys#macro-environment)
- (##sys#current-environment)
- iexports vexports sexports sdlist)))
- (##sys#mark-imported-symbols iexports)
- (for-each
- (lambda (m)
- (let ((se (merge-se (cadr m) new-se))) ;XXX needed?
- (dm `(FIXUP: ,(car m) ,@(map-se se)))
- (set-car! (cdr m) se)))
- sdlist)
- (dm `(EXPORTS:
- ,(module-name mod)
- (DLIST: ,@dlist)
- (SDLIST: ,@(map-se sdlist))
- (IEXPORTS: ,@(map-se iexports))
- (VEXPORTS: ,@(map-se vexports))
- (SEXPORTS: ,@(map-se sexports))))
- (set-module-vexports! mod vexports)
- (set-module-sexports! mod sexports))))
+(define ##sys#finalize-module
+ (let ((display display)
+ (write-char write-char))
+ (lambda (mod)
+ (let* ((explist (module-export-list mod))
+ (name (module-name mod))
+ (dlist (module-defined-list mod))
+ (elist (module-exist-list mod))
+ (missing #f)
+ (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
+ (module-defined-syntax-list mod)))
+ (sexports
+ (if (eq? #t explist)
+ sdlist
+ (let loop ((me (##sys#macro-environment)))
+ (cond ((null? me) '())
+ ((##sys#find-export (caar me) mod #f)
+ (cons (car me) (loop (cdr me))))
+ (else (loop (cdr me)))))))
+ (vexports
+ (let loop ((xl (if (eq? #t explist) elist explist)))
+ (if (null? xl)
+ '()
+ (let* ((h (car xl))
+ (id (if (symbol? h) h (car h))))
+ (if (assq id sexports)
+ (loop (cdr xl))
+ (cons
+ (cons
+ id
+ (let ((def (assq id dlist)))
+ (if (and def (symbol? (cdr def)))
+ (cdr def)
+ (let ((a (assq id (##sys#current-environment))))
+ (cond ((and a (symbol? (cdr a)))
+ (dm "reexporting: " id " -> " (cdr a))
+ (cdr a))
+ ((not def)
+ (set! missing #t)
+ (##sys#warn
+ (string-append
+ "exported identifier of module `"
+ (symbol->string name)
+ "' has not been defined")
+ id)
+ #f)
+ (else (##sys#module-rename id name)))))))
+ (loop (cdr xl)))))))))
+ (for-each
+ (lambda (u)
+ (let* ((where (cdr u))
+ (u (car u)))
+ (unless (memq u elist)
+ (let ((out (open-output-string)))
+ (set! missing #t)
+ (display "reference to possibly unbound identifier `" out)
+ (display u out)
+ (write-char #\' out)
+ (when (pair? where)
+ (display " in:" out)
+ (for-each
+ (lambda (sym)
+ (display "\nWarning: " out)
+ (display sym out))
+ where))
+ (and-let* ((a (getp u '##core#db)))
+ (cond ((= 1 (length a))
+ (display "\nWarning: suggesting: `(import " out)
+ (display (cadar a) out)
+ (display ")'" out))
+ (else
+ (display "\nWarning: suggesting one of:" out)
+ (for-each
+ (lambda (a)
+ (display "\nWarning: (import " out)
+ (display (cadr a) out)
+ (write-char #\) out))
+ a))))
+ (##sys#warn (get-output-string out))))))
+ (module-undefined-list mod))
+ (when missing
+ (##sys#error "module unresolved" name))
+ (let* ((iexports
+ (map (lambda (exp)
+ (cond ((symbol? (cdr exp)) exp)
+ ((assq (car exp) (##sys#macro-environment)))
+ (else (##sys#error "(internal) indirect export not found" (car exp)))) )
+ (module-indirect-exports mod)))
+ (new-se (merge-se
+ (##sys#macro-environment)
+ (##sys#current-environment)
+ iexports vexports sexports sdlist)))
+ (##sys#mark-imported-symbols iexports)
+ (for-each
+ (lambda (m)
+ (let ((se (merge-se (cadr m) new-se))) ;XXX needed?
+ (dm `(FIXUP: ,(car m) ,@(map-se se)))
+ (set-car! (cdr m) se)))
+ sdlist)
+ (dm `(EXPORTS:
+ ,(module-name mod)
+ (DLIST: ,@dlist)
+ (SDLIST: ,@(map-se sdlist))
+ (IEXPORTS: ,@(map-se iexports))
+ (VEXPORTS: ,@(map-se vexports))
+ (SEXPORTS: ,@(map-se sexports))))
+ (set-module-vexports! mod vexports)
+ (set-module-sexports! mod sexports))))))
(define ##sys#module-table '())
Trap