1233 |
;; |
;; |
1234 |
(define (module-symbol-local-binding m v . opt-val) |
(define (module-symbol-local-binding m v . opt-val) |
1235 |
(let ((var (module-local-variable m v))) |
(let ((var (module-local-variable m v))) |
1236 |
(if var |
(if (and var (variable-bound? var)) |
1237 |
(variable-ref var) |
(variable-ref var) |
1238 |
(if (not (null? opt-val)) |
(if (not (null? opt-val)) |
1239 |
(car opt-val) |
(car opt-val) |
1248 |
;; |
;; |
1249 |
(define (module-symbol-binding m v . opt-val) |
(define (module-symbol-binding m v . opt-val) |
1250 |
(let ((var (module-variable m v))) |
(let ((var (module-variable m v))) |
1251 |
(if var |
(if (and var (variable-bound? var)) |
1252 |
(variable-ref var) |
(variable-ref var) |
1253 |
(if (not (null? opt-val)) |
(if (not (null? opt-val)) |
1254 |
(car opt-val) |
(car opt-val) |
1447 |
(cons interface (delq! interface (module-uses module)))) |
(cons interface (delq! interface (module-uses module)))) |
1448 |
(module-modified module)) |
(module-modified module)) |
1449 |
|
|
1450 |
|
;; MODULE-USE-INTERFACES! module interfaces |
1451 |
|
;; |
1452 |
|
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates |
1453 |
|
;; |
1454 |
|
(define (module-use-interfaces! module interfaces) |
1455 |
|
(let* ((duplicates-info (module-duplicates-info module)) |
1456 |
|
(duplicates-handlers? (car duplicates-info)) |
1457 |
|
(uses (module-uses module))) |
1458 |
|
;; remove duplicates-interface |
1459 |
|
(set! uses (delq! (cdr duplicates-info) uses)) |
1460 |
|
;; remove interfaces to be added |
1461 |
|
(for-each (lambda (interface) |
1462 |
|
(set! uses (delq! interface uses))) |
1463 |
|
interfaces) |
1464 |
|
;; add interfaces to use list |
1465 |
|
(set-module-uses! module uses) |
1466 |
|
(for-each (lambda (interface) |
1467 |
|
(and duplicates-handlers? |
1468 |
|
;; perform duplicate checking |
1469 |
|
(process-duplicates module interface)) |
1470 |
|
(set! uses (cons interface uses)) |
1471 |
|
(set-module-uses! module uses)) |
1472 |
|
interfaces) |
1473 |
|
;; add duplicates interface |
1474 |
|
(if (cdr duplicates-info) |
1475 |
|
(set-module-uses! module (cons (cdr duplicates-info) uses))) |
1476 |
|
(module-modified module))) |
1477 |
|
|
1478 |
|
|
1479 |
;;; {Recursive Namespaces} |
;;; {Recursive Namespaces} |
1480 |
;;; |
;;; |
1562 |
(module-ref m '%module-public-interface #f)) |
(module-ref m '%module-public-interface #f)) |
1563 |
(define (set-module-public-interface! m i) |
(define (set-module-public-interface! m i) |
1564 |
(module-define! m '%module-public-interface i)) |
(module-define! m '%module-public-interface i)) |
1565 |
|
(define (module-duplicates-info m) |
1566 |
|
(or (module-ref m '%module-duplicates-info #f) (cons #f #f))) |
1567 |
|
(define (set-module-duplicates-info! m i) |
1568 |
|
(module-define! m '%module-duplicates-info i)) |
1569 |
(define (set-system-module! m s) |
(define (set-system-module! m s) |
1570 |
(set-procedure-property! (module-eval-closure m) 'system-module s)) |
(set-procedure-property! (module-eval-closure m) 'system-module s)) |
1571 |
(define the-root-module (make-root-module)) |
(define the-root-module (make-root-module)) |
1572 |
(define the-scm-module (make-scm-module)) |
(define the-scm-module (make-scm-module)) |
1573 |
(set-module-public-interface! the-root-module the-scm-module) |
(set-module-public-interface! the-root-module the-scm-module) |
1574 |
|
(set-module-duplicates-info! the-root-module (cons #f #f)) |
1575 |
(set-module-name! the-root-module '(guile)) |
(set-module-name! the-root-module '(guile)) |
1576 |
(set-module-name! the-scm-module '(guile)) |
(set-module-name! the-scm-module '(guile)) |
1577 |
(set-module-kind! the-scm-module 'interface) |
(set-module-kind! the-scm-module 'interface) |
1600 |
(let ((interface (make-module 31))) |
(let ((interface (make-module 31))) |
1601 |
(set-module-name! interface (module-name module)) |
(set-module-name! interface (module-name module)) |
1602 |
(set-module-kind! interface 'interface) |
(set-module-kind! interface 'interface) |
1603 |
(set-module-public-interface! module interface)))) |
(set-module-public-interface! module interface) |
1604 |
|
(set-module-duplicates-info! module (cons #f #f))))) |
1605 |
(if (and (not (memq the-scm-module (module-uses module))) |
(if (and (not (memq the-scm-module (module-uses module))) |
1606 |
(not (eq? module the-root-module))) |
(not (eq? module the-root-module))) |
1607 |
(set-module-uses! module (append (module-uses module) (list the-scm-module))))) |
(set-module-uses! module |
1608 |
|
(append (module-uses module) (list the-scm-module))))) |
1609 |
|
|
1610 |
;; NOTE: This binding is used in libguile/modules.c. |
;; NOTE: This binding is used in libguile/modules.c. |
1611 |
;; |
;; |
1743 |
(re-exports '())) |
(re-exports '())) |
1744 |
(if (null? kws) |
(if (null? kws) |
1745 |
(begin |
(begin |
1746 |
(for-each (lambda (interface) |
(module-use-interfaces! module (reverse reversed-interfaces)) |
|
(module-use! module interface)) |
|
|
(reverse reversed-interfaces)) |
|
1747 |
(module-export! module exports) |
(module-export! module exports) |
1748 |
(module-re-export! module re-exports)) |
(module-re-export! module re-exports)) |
1749 |
(case (car kws) |
(case (car kws) |
1781 |
((#:pure) |
((#:pure) |
1782 |
(purify-module! module) |
(purify-module! module) |
1783 |
(loop (cdr kws) reversed-interfaces exports re-exports)) |
(loop (cdr kws) reversed-interfaces exports re-exports)) |
1784 |
|
((#:duplicates) |
1785 |
|
(if (not (pair? (cdr kws))) |
1786 |
|
(unrecognized kws)) |
1787 |
|
(set-car! (module-duplicates-info module) |
1788 |
|
(map (lambda (handler-name) |
1789 |
|
(or (module-symbol-local-binding |
1790 |
|
duplicate-handlers handler-name #f) |
1791 |
|
(error "invalid duplicate handler name:" |
1792 |
|
handler-name))) |
1793 |
|
(if (list? (cadr kws)) |
1794 |
|
(cadr kws) |
1795 |
|
(list (cadr kws))))) |
1796 |
|
(loop (cddr kws) reversed-interfaces exports re-exports)) |
1797 |
((#:export #:export-syntax) |
((#:export #:export-syntax) |
1798 |
(or (pair? (cdr kws)) |
(or (pair? (cdr kws)) |
1799 |
(unrecognized kws)) |
(unrecognized kws)) |
2595 |
;; to change scm_c_use_module as well. |
;; to change scm_c_use_module as well. |
2596 |
|
|
2597 |
(define (process-use-modules module-interface-args) |
(define (process-use-modules module-interface-args) |
2598 |
(for-each (lambda (mif-args) |
(module-use-interfaces! (current-module) |
2599 |
(let ((mod-iface (apply resolve-interface mif-args))) |
(map (lambda (mif-args) |
2600 |
(or mod-iface |
(or (apply resolve-interface mif-args) |
2601 |
(error "no such module" mif-args)) |
(error "no such module" mif-args))) |
2602 |
(module-use! (current-module) mod-iface))) |
module-interface-args))) |
|
module-interface-args)) |
|
2603 |
|
|
2604 |
(defmacro use-modules modules |
(defmacro use-modules modules |
2605 |
`(eval-case |
`(eval-case |
2607 |
(process-use-modules |
(process-use-modules |
2608 |
(list ,@(map (lambda (m) |
(list ,@(map (lambda (m) |
2609 |
`(list ,@(compile-interface-spec m))) |
`(list ,@(compile-interface-spec m))) |
2610 |
modules)))) |
modules))) |
2611 |
|
*unspecified*) |
2612 |
(else |
(else |
2613 |
(error "use-modules can only be used at the top level")))) |
(error "use-modules can only be used at the top level")))) |
2614 |
|
|
2711 |
(define load load-module) |
(define load load-module) |
2712 |
|
|
2713 |
|
|
2714 |
|
;;; {Handling of duplicate imported bindings} |
2715 |
|
;;; |
2716 |
|
|
2717 |
|
;; Duplicate handlers take the following arguments: |
2718 |
|
;; |
2719 |
|
;; module importing module |
2720 |
|
;; name conflicting name |
2721 |
|
;; int1 old interface where name occurs |
2722 |
|
;; val1 value of binding in old interface |
2723 |
|
;; int2 new interface where name occurs |
2724 |
|
;; val2 value of binding in new interface |
2725 |
|
;; var previous resolution or #f |
2726 |
|
;; val value of previous resolution |
2727 |
|
;; |
2728 |
|
;; A duplicate handler can take three alternative actions: |
2729 |
|
;; |
2730 |
|
;; 1. return #f => leave responsibility to next handler |
2731 |
|
;; 2. exit with an error |
2732 |
|
;; 3. return a variable resolving the conflict |
2733 |
|
;; |
2734 |
|
|
2735 |
|
(define duplicate-handlers |
2736 |
|
(let ((m (make-module 7))) |
2737 |
|
(set-module-name! m 'duplicate-handlers) |
2738 |
|
(set-module-kind! m 'interface) |
2739 |
|
(module-define! m 'check |
2740 |
|
(lambda (module name int1 val1 int2 val2 var val) |
2741 |
|
(scm-error 'misc-error |
2742 |
|
#f |
2743 |
|
"module ~A: duplicate binding ~A imported from ~A and ~A" |
2744 |
|
(list (module-name module) |
2745 |
|
name |
2746 |
|
(module-name int1) |
2747 |
|
(module-name int2)) |
2748 |
|
#f))) |
2749 |
|
(module-define! m 'first |
2750 |
|
(lambda (module name int1 val1 int2 val2 var val) |
2751 |
|
(or var (module-local-variable int1 name)))) |
2752 |
|
(module-define! m 'last |
2753 |
|
(lambda (module name int1 val1 int2 val2 var val) |
2754 |
|
(module-local-variable int2 name))) |
2755 |
|
m)) |
2756 |
|
|
2757 |
|
(define (make-duplicates-interface) |
2758 |
|
(let ((m (make-module))) |
2759 |
|
(set-module-kind! m 'interface) |
2760 |
|
(set-module-name! m 'duplicates) |
2761 |
|
m)) |
2762 |
|
|
2763 |
|
(define (module-symbol-interface module sym) |
2764 |
|
(or-map (lambda (interface) |
2765 |
|
(module-search (lambda (interface sym) |
2766 |
|
(and (module-local-variable interface sym) |
2767 |
|
interface)) |
2768 |
|
interface |
2769 |
|
sym)) |
2770 |
|
(module-uses module))) |
2771 |
|
|
2772 |
|
(define (process-duplicates module interface) |
2773 |
|
(let* ((duplicates-info (module-duplicates-info module)) |
2774 |
|
(handlers (car duplicates-info)) |
2775 |
|
(d-interface (cdr duplicates-info))) |
2776 |
|
(module-for-each |
2777 |
|
(lambda (name var) |
2778 |
|
(let ((prev-interface (module-symbol-interface module name))) |
2779 |
|
(if prev-interface |
2780 |
|
(begin |
2781 |
|
(if (not d-interface) |
2782 |
|
(begin |
2783 |
|
(set! d-interface (make-duplicates-interface)) |
2784 |
|
(set-cdr! duplicates-info d-interface))) |
2785 |
|
(let* ((var (module-local-variable d-interface name)) |
2786 |
|
(val (and var (variable-bound? var) (variable-ref var)))) |
2787 |
|
(let loop ((handlers handlers)) |
2788 |
|
(cond ((null? handlers)) |
2789 |
|
(((car handlers) |
2790 |
|
module |
2791 |
|
name |
2792 |
|
prev-interface |
2793 |
|
(module-symbol-local-binding prev-interface name #f) |
2794 |
|
interface |
2795 |
|
(module-symbol-local-binding interface name #f) |
2796 |
|
var |
2797 |
|
val) |
2798 |
|
=> |
2799 |
|
(lambda (var) |
2800 |
|
(module-add! d-interface name var))) |
2801 |
|
(else |
2802 |
|
(loop (cdr handlers)))))))))) |
2803 |
|
interface))) |
2804 |
|
|
2805 |
|
|
2806 |
|
|
2807 |
;;; {`cond-expand' for SRFI-0 support.} |
;;; {`cond-expand' for SRFI-0 support.} |
2808 |
;;; |
;;; |