2837 |
m)) |
m)) |
2838 |
|
|
2839 |
(define (lookup-duplicates-handlers handler-names) |
(define (lookup-duplicates-handlers handler-names) |
2840 |
(map (lambda (handler-name) |
(and handler-names |
2841 |
(or (module-symbol-local-binding |
(map (lambda (handler-name) |
2842 |
duplicate-handlers handler-name #f) |
(or (module-symbol-local-binding |
2843 |
(error "invalid duplicate handler name:" |
duplicate-handlers handler-name #f) |
2844 |
handler-name))) |
(error "invalid duplicate handler name:" |
2845 |
(if (list? handler-names) |
handler-name))) |
2846 |
handler-names |
(if (list? handler-names) |
2847 |
(list handler-names)))) |
handler-names |
2848 |
|
(list handler-names))))) |
2849 |
|
|
2850 |
(define default-module-duplicates-handler |
(define default-module-duplicates-handler |
2851 |
(make-mutable-parameter '(replace warn-override-core check) |
(make-mutable-parameter '(replace warn-override-core check) |
2857 |
(set-module-name! m 'duplicates) |
(set-module-name! m 'duplicates) |
2858 |
m)) |
m)) |
2859 |
|
|
|
(define (module-symbol-interface module sym) |
|
|
(or-map (lambda (interface) |
|
|
(module-search (lambda (interface sym) |
|
|
(and (module-local-variable interface sym) |
|
|
interface)) |
|
|
interface |
|
|
sym)) |
|
|
(module-uses module))) |
|
|
|
|
2860 |
(define (process-duplicates module interface) |
(define (process-duplicates module interface) |
2861 |
(let* ((duplicates-info (module-duplicates-info module)) |
(let* ((duplicates-info (module-duplicates-info module)) |
2862 |
(duplicates-handlers (car duplicates-info)) |
(duplicates-handlers (car duplicates-info)) |
2863 |
(duplicates-interface (cdr duplicates-info))) |
(duplicates-interface (cdr duplicates-info))) |
2864 |
(module-for-each |
(module-for-each |
2865 |
(lambda (name var) |
(lambda (name var) |
2866 |
(let ((prev-interface (module-symbol-interface module name))) |
(cond ((module-import-interface module name) |
2867 |
(if prev-interface |
=> |
2868 |
(let ((var1 (module-local-variable prev-interface name)) |
(lambda (prev-interface) |
2869 |
(var2 (module-local-variable interface name))) |
(let ((var1 (module-local-variable prev-interface name)) |
2870 |
(if (not (eq? var1 var2)) |
(var2 (module-local-variable interface name))) |
2871 |
(begin |
(if (not (eq? var1 var2)) |
2872 |
(if (not duplicates-interface) |
(begin |
2873 |
(begin |
(if (not duplicates-interface) |
2874 |
(set! duplicates-interface |
(begin |
2875 |
(make-duplicates-interface)) |
(set! duplicates-interface |
2876 |
(set-cdr! duplicates-info duplicates-interface))) |
(make-duplicates-interface)) |
2877 |
(let* ((var (module-local-variable duplicates-interface |
(set-cdr! duplicates-info duplicates-interface))) |
2878 |
name)) |
(let* ((var (module-local-variable duplicates-interface |
2879 |
(val (and var |
name)) |
2880 |
(variable-bound? var) |
(val (and var |
2881 |
(variable-ref var)))) |
(variable-bound? var) |
2882 |
(let loop ((duplicates-handlers duplicates-handlers)) |
(variable-ref var)))) |
2883 |
(cond ((null? duplicates-handlers)) |
(let loop ((duplicates-handlers duplicates-handlers)) |
2884 |
(((car duplicates-handlers) |
(cond ((null? duplicates-handlers)) |
2885 |
module |
(((car duplicates-handlers) |
2886 |
name |
module |
2887 |
prev-interface |
name |
2888 |
(and (variable-bound? var1) |
prev-interface |
2889 |
(variable-ref var1)) |
(and (variable-bound? var1) |
2890 |
interface |
(variable-ref var1)) |
2891 |
(and (variable-bound? var2) |
interface |
2892 |
(variable-ref var2)) |
(and (variable-bound? var2) |
2893 |
var |
(variable-ref var2)) |
2894 |
val) |
var |
2895 |
=> |
val) |
2896 |
(lambda (var) |
=> |
2897 |
(module-add! duplicates-interface name var))) |
(lambda (var) |
2898 |
(else |
(module-add! duplicates-interface name var))) |
2899 |
(loop (cdr duplicates-handlers)))))))))))) |
(else |
2900 |
|
(loop (cdr duplicates-handlers))))))))))))) |
2901 |
interface))) |
interface))) |
2902 |
|
|
2903 |
|
|