/[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.299 by mdj, Wed Feb 19 16:16:40 2003 UTC revision 1.300 by mdj, Fri Mar 7 13:11:52 2003 UTC
# Line 1233  Line 1233 
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)
# Line 1248  Line 1248 
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)
# Line 1447  Line 1447 
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  ;;;  ;;;
# Line 1534  Line 1562 
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)
# Line 1567  Line 1600 
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  ;;  ;;
# Line 1708  Line 1743 
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)
# Line 1748  Line 1781 
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))
# Line 2549  Line 2595 
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
# Line 2562  Line 2607 
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    
# Line 2665  Line 2711 
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  ;;;  ;;;

Legend:
Removed from v.1.299  
changed lines
  Added in v.1.300

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