2843 |
(module-name int2)) |
(module-name int2)) |
2844 |
#f)) |
#f)) |
2845 |
|
|
2846 |
(define (warn module name int1 val1 int2 val2 var val) |
(define (warn module name int1 val1 int2 val2 var val) |
2847 |
(format #t |
(format #t |
2848 |
"WARNING: ~A: `~A' imported from both ~A and ~A\n" |
"WARNING: ~A: `~A' imported from both ~A and ~A\n" |
2849 |
(module-name module) |
(module-name module) |
2850 |
name |
name |
2851 |
(module-name int1) |
(module-name int1) |
2852 |
(module-name int2)) |
(module-name int2)) |
2853 |
#f) |
#f) |
2854 |
|
|
2855 |
(define (replace module name int1 val1 int2 val2 var val) |
(define (replace module name int1 val1 int2 val2 var val) |
2856 |
(let ((old (or (and var (object-property var 'replace) var) |
(let ((old (or (and var (object-property var 'replace) var) |
2863 |
(and (object-property new 'replace) |
(and (object-property new 'replace) |
2864 |
new)))) |
new)))) |
2865 |
|
|
2866 |
(define (warn-override-core module name int1 val1 int2 val2 var val) |
(define (warn-override-core module name int1 val1 int2 val2 var val) |
2867 |
(and (eq? int1 the-scm-module) |
(and (eq? int1 the-scm-module) |
2868 |
(begin |
(begin |
2869 |
(format #t |
(format #t |
2870 |
"WARNING: ~A: imported module ~A overrides core binding `~A'\n" |
"WARNING: ~A: imported module ~A overrides core binding `~A'\n" |
2871 |
(module-name module) |
(module-name module) |
2872 |
(module-name int2) |
(module-name int2) |
2873 |
name) |
name) |
2874 |
(module-local-variable int2 name)))) |
(module-local-variable int2 name)))) |
2875 |
|
|
2876 |
(define (first module name int1 val1 int2 val2 var val) |
(define (first module name int1 val1 int2 val2 var val) |
2877 |
(or var (module-local-variable int1 name))) |
(or var (module-local-variable int1 name))) |
2878 |
|
|
2879 |
(define (last module name int1 val1 int2 val2 var val) |
(define (last module name int1 val1 int2 val2 var val) |
2880 |
(module-local-variable int2 name)) |
(module-local-variable int2 name)) |
2881 |
|
|
2882 |
|
(define (noop module name int1 val1 int2 val2 var val) |
2883 |
|
#f) |
2884 |
|
|
2885 |
(set-module-name! m 'duplicate-handlers) |
(set-module-name! m 'duplicate-handlers) |
2886 |
(set-module-kind! m 'interface) |
(set-module-kind! m 'interface) |
2887 |
(module-define! m 'check check) |
(module-define! m 'check check) |
2890 |
(module-define! m 'warn-override-core warn-override-core) |
(module-define! m 'warn-override-core warn-override-core) |
2891 |
(module-define! m 'first first) |
(module-define! m 'first first) |
2892 |
(module-define! m 'last last) |
(module-define! m 'last last) |
2893 |
|
(module-define! m 'merge-generics noop) |
2894 |
|
(module-define! m 'merge-accessors noop) |
2895 |
m)) |
m)) |
2896 |
|
|
2897 |
(define (lookup-duplicates-handlers handler-names) |
(define (lookup-duplicates-handlers handler-names) |