1444 |
;; |
;; |
1445 |
(define (module-use! module interface) |
(define (module-use! module interface) |
1446 |
(set-module-uses! module |
(set-module-uses! module |
1447 |
(cons interface (delq! interface (module-uses module)))) |
(cons interface |
1448 |
|
(filter (lambda (m) |
1449 |
|
(not (equal? (module-name m) |
1450 |
|
(module-name interface)))) |
1451 |
|
(module-uses module)))) |
1452 |
(module-modified module)) |
(module-modified module)) |
1453 |
|
|
1454 |
;; MODULE-USE-INTERFACES! module interfaces |
;; MODULE-USE-INTERFACES! module interfaces |
1463 |
(set! uses (delq! (cdr duplicates-info) uses)) |
(set! uses (delq! (cdr duplicates-info) uses)) |
1464 |
;; remove interfaces to be added |
;; remove interfaces to be added |
1465 |
(for-each (lambda (interface) |
(for-each (lambda (interface) |
1466 |
(set! uses (delq! interface uses))) |
(set! uses |
1467 |
|
(filter (lambda (m) |
1468 |
|
(not (equal? (module-name m) |
1469 |
|
(module-name interface)))) |
1470 |
|
uses))) |
1471 |
interfaces) |
interfaces) |
1472 |
;; add interfaces to use list |
;; add interfaces to use list |
1473 |
(set-module-uses! module uses) |
(set-module-uses! module uses) |
1671 |
;; Return a module that is an interface to the module designated by |
;; Return a module that is an interface to the module designated by |
1672 |
;; NAME. |
;; NAME. |
1673 |
;; |
;; |
1674 |
;; `resolve-interface' takes two keyword arguments: |
;; `resolve-interface' takes four keyword arguments: |
1675 |
;; |
;; |
1676 |
;; #:select SELECTION |
;; #:select SELECTION |
1677 |
;; |
;; |
1684 |
;; are made available in the interface. Bindings that are added later |
;; are made available in the interface. Bindings that are added later |
1685 |
;; are not picked up. |
;; are not picked up. |
1686 |
;; |
;; |
1687 |
;; #:renamer RENAMER |
;; #:hide BINDINGS |
1688 |
;; |
;; |
1689 |
;; RENAMER is a procedure that takes a symbol and returns its new |
;; BINDINGS is a list of bindings which should not be imported. |
|
;; name. The default is to append a specified prefix (see below) or |
|
|
;; not perform any renaming. |
|
1690 |
;; |
;; |
1691 |
;; #:prefix PREFIX |
;; #:prefix PREFIX |
1692 |
;; |
;; |
1693 |
;; PREFIX is a symbol that will be appended to each exported name. |
;; PREFIX is a symbol that will be appended to each exported name. |
1694 |
;; The default is to not perform any renaming. |
;; The default is to not perform any renaming. |
1695 |
;; |
;; |
1696 |
|
;; #:renamer RENAMER |
1697 |
|
;; |
1698 |
|
;; RENAMER is a procedure that takes a symbol and returns its new |
1699 |
|
;; name. The default is not perform any renaming. |
1700 |
|
;; |
1701 |
;; Signal "no code for module" error if module name is not resolvable |
;; Signal "no code for module" error if module name is not resolvable |
1702 |
;; or its public interface is not available. Signal "no binding" |
;; or its public interface is not available. Signal "no binding" |
1703 |
;; error if selected binding does not exist in the used module. |
;; error if selected binding does not exist in the used module. |
1714 |
def))) |
def))) |
1715 |
|
|
1716 |
(let* ((select (get-keyword-arg args #:select #f)) |
(let* ((select (get-keyword-arg args #:select #f)) |
1717 |
|
(hide (get-keyword-arg args #:hide '())) |
1718 |
(renamer (or (get-keyword-arg args #:renamer #f) |
(renamer (or (get-keyword-arg args #:renamer #f) |
1719 |
(let ((prefix (get-keyword-arg args #:prefix #f))) |
(let ((prefix (get-keyword-arg args #:prefix #f))) |
1720 |
(and prefix (symbol-prefix-proc prefix))) |
(and prefix (symbol-prefix-proc prefix))) |
1723 |
(public-i (and module (module-public-interface module)))) |
(public-i (and module (module-public-interface module)))) |
1724 |
(and (or (not module) (not public-i)) |
(and (or (not module) (not public-i)) |
1725 |
(error "no code for module" name)) |
(error "no code for module" name)) |
1726 |
(if (and (not select) (eq? renamer identity)) |
(if (and (not select) (null? hide) (eq? renamer identity)) |
1727 |
public-i |
public-i |
1728 |
(let ((selection (or select (module-map (lambda (sym var) sym) |
(let ((selection (or select (module-map (lambda (sym var) sym) |
1729 |
public-i))) |
public-i))) |
1730 |
(custom-i (make-module 31))) |
(custom-i (make-module 31))) |
1731 |
(set-module-kind! custom-i 'interface) |
(set-module-kind! custom-i 'custom-interface) |
1732 |
|
(set-module-name! custom-i name) |
1733 |
;; XXX - should use a lazy binder so that changes to the |
;; XXX - should use a lazy binder so that changes to the |
1734 |
;; used module are picked up automatically. |
;; used module are picked up automatically. |
1735 |
(for-each (lambda (bspec) |
(for-each (lambda (bspec) |
1736 |
(let* ((direct? (symbol? bspec)) |
(let* ((direct? (symbol? bspec)) |
1737 |
(orig (if direct? bspec (car bspec))) |
(orig (if direct? bspec (car bspec))) |
1738 |
(seen (if direct? bspec (cdr bspec)))) |
(seen (if direct? bspec (cdr bspec))) |
1739 |
(module-add! custom-i (renamer seen) |
(var (or (module-local-variable public-i orig) |
1740 |
(or (module-local-variable public-i orig) |
(module-local-variable module orig) |
1741 |
(module-local-variable module orig) |
(error |
1742 |
(error |
;; fixme: format manually for now |
1743 |
;; fixme: format manually for now |
(simple-format |
1744 |
(simple-format |
#f "no binding `~A' in module ~A" |
1745 |
#f "no binding `~A' in module ~A" |
orig name))))) |
1746 |
orig name)))))) |
(if (memq orig hide) |
1747 |
|
(set! hide (delq! orig hide)) |
1748 |
|
(module-add! custom-i |
1749 |
|
(renamer seen) |
1750 |
|
var)))) |
1751 |
selection) |
selection) |
1752 |
|
;; Check that we are not hiding bindings which don't exist |
1753 |
|
(for-each (lambda (binding) |
1754 |
|
(if (not (module-local-variable public-i binding)) |
1755 |
|
(error |
1756 |
|
(simple-format |
1757 |
|
#f "no binding `~A' to hide in module ~A" |
1758 |
|
binding name)))) |
1759 |
|
hide) |
1760 |
custom-i)))) |
custom-i)))) |
1761 |
|
|
1762 |
(define (symbol-prefix-proc prefix) |
(define (symbol-prefix-proc prefix) |
2576 |
(define keys |
(define keys |
2577 |
;; sym key quote? |
;; sym key quote? |
2578 |
'((:select #:select #t) |
'((:select #:select #t) |
2579 |
|
(:hide #:hide #t) |
2580 |
(:prefix #:prefix #t) |
(:prefix #:prefix #t) |
2581 |
(:renamer #:renamer #f))) |
(:renamer #:renamer #f))) |
2582 |
(if (not (pair? (car spec))) |
(if (not (pair? (car spec))) |
2879 |
|
|
2880 |
(define (make-duplicates-interface) |
(define (make-duplicates-interface) |
2881 |
(let ((m (make-module))) |
(let ((m (make-module))) |
2882 |
(set-module-kind! m 'interface) |
(set-module-kind! m 'custom-interface) |
2883 |
(set-module-name! m 'duplicates) |
(set-module-name! m 'duplicates) |
2884 |
m)) |
m)) |
2885 |
|
|