/[guile]/guile/guile-core/ice-9/boot-9.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/boot-9.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.302 by mdj, Tue Mar 11 15:57:56 2003 UTC revision 1.303 by mdj, Tue Mar 11 19:57:36 2003 UTC
# Line 1444  Line 1444 
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
# Line 1459  Line 1463 
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)
# Line 1663  Line 1671 
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  ;;  ;;
# Line 1676  Line 1684 
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.
# Line 1703  Line 1714 
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)))
# Line 1711  Line 1723 
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)
# Line 2551  Line 2576 
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)))
# Line 2853  Line 2879 
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    

Legend:
Removed from v.1.302  
changed lines
  Added in v.1.303

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26