;;; installed-scm-file
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
(define (1+ n) (+ n 1))
(define (1- n) (+ n -1))
(define (and=> value procedure) (and value (procedure value)))
-(define (make-hash-table k) (make-vector k '()))
;;; apply-to-args is functionally redundant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
(if (> (length args) 3)
(error "Too many args to make-module." args))
- (let ((size (parse-arg 0 1021))
+ (let ((size (parse-arg 0 31))
(uses (parse-arg 1 '()))
(binder (parse-arg 2 #f)))
(error
"Lazy-binder expected to be a procedure or #f." binder))
- (let ((module (module-constructor (make-vector size '())
+ (let ((module (module-constructor (and (not (zero? size))
+ (make-hash-table size))
uses binder #f #f #f #f
'()
(make-weak-value-hash-table 31)
;;
(define (module-symbol-local-binding m v . opt-val)
(let ((var (module-local-variable m v)))
- (if var
+ (if (and var (variable-bound? var))
(variable-ref var)
(if (not (null? opt-val))
(car opt-val)
;;
(define (module-symbol-binding m v . opt-val)
(let ((var (module-variable m v)))
- (if var
+ (if (and var (variable-bound? var))
(variable-ref var)
(if (not (null? opt-val))
(car opt-val)
;; make sure that a symbol is undefined in the local namespace of M.
;;
(define (module-remove! m v)
- (module-obarray-remove! (module-obarray m) v)
+ (module-obarray-remove! (module-obarray m) v)
(module-modified m))
(define (module-clear! m)
- (vector-fill! (module-obarray m) '())
+ (hash-clear! (module-obarray m))
(module-modified m))
;; MODULE-FOR-EACH -- exported
;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
;;
(define (module-for-each proc module)
- (let ((obarray (module-obarray module)))
- (do ((index 0 (+ index 1))
- (end (vector-length obarray)))
- ((= index end))
- (for-each
- (lambda (bucket)
- (proc (car bucket) (cdr bucket)))
- (vector-ref obarray index)))))
-
+ (hash-for-each proc (module-obarray module)))
(define (module-map proc module)
- (let* ((obarray (module-obarray module))
- (end (vector-length obarray)))
-
- (let loop ((i 0)
- (answer '()))
- (if (= i end)
- answer
- (loop (+ 1 i)
- (append!
- (map (lambda (bucket)
- (proc (car bucket) (cdr bucket)))
- (vector-ref obarray i))
- answer))))))
+ (hash-map proc (module-obarray module)))
+
\f
;;; {Low Level Bootstrapping}
(cons interface (delq! interface (module-uses module))))
(module-modified module))
+;; MODULE-USE-INTERFACES! module interfaces
+;;
+;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
+;;
+(define (module-use-interfaces! module interfaces)
+ (let* ((duplicates-info (module-duplicates-info module))
+ (duplicates-handlers? (car duplicates-info))
+ (uses (module-uses module)))
+ ;; remove duplicates-interface
+ (set! uses (delq! (cdr duplicates-info) uses))
+ ;; remove interfaces to be added
+ (for-each (lambda (interface)
+ (set! uses (delq! interface uses)))
+ interfaces)
+ ;; add interfaces to use list
+ (set-module-uses! module uses)
+ (for-each (lambda (interface)
+ (and duplicates-handlers?
+ ;; perform duplicate checking
+ (process-duplicates module interface))
+ (set! uses (cons interface uses))
+ (set-module-uses! module uses))
+ interfaces)
+ ;; add duplicates interface
+ (if (cdr duplicates-info)
+ (set-module-uses! module (cons (cdr duplicates-info) uses)))
+ (module-modified module)))
+
\f
;;; {Recursive Namespaces}
;;;
(module-ref m '%module-public-interface #f))
(define (set-module-public-interface! m i)
(module-define! m '%module-public-interface i))
+(define (module-duplicates-info m)
+ (or (module-ref m '%module-duplicates-info #f) (cons #f #f)))
+(define (set-module-duplicates-info! m i)
+ (module-define! m '%module-duplicates-info i))
(define (set-system-module! m s)
(set-procedure-property! (module-eval-closure m) 'system-module s))
(define the-root-module (make-root-module))
(define the-scm-module (make-scm-module))
(set-module-public-interface! the-root-module the-scm-module)
+(set-module-duplicates-info! the-root-module (cons #f #f))
(set-module-name! the-root-module '(guile))
(set-module-name! the-scm-module '(guile))
(set-module-kind! the-scm-module 'interface)
(let ((interface (make-module 31)))
(set-module-name! interface (module-name module))
(set-module-kind! interface 'interface)
- (set-module-public-interface! module interface))))
+ (set-module-public-interface! module interface)
+ (set-module-duplicates-info! module (cons #f #f)))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
- (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
+ (set-module-uses! module
+ (append (module-uses module) (list the-scm-module)))))
;; NOTE: This binding is used in libguile/modules.c.
;;
(re-exports '()))
(if (null? kws)
(begin
- (for-each (lambda (interface)
- (module-use! module interface))
- (reverse reversed-interfaces))
+ (module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports)
(module-re-export! module re-exports))
(case (car kws)
((#:pure)
(purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports))
+ ((#:duplicates)
+ (if (not (pair? (cdr kws)))
+ (unrecognized kws))
+ (set-car! (module-duplicates-info module)
+ (map (lambda (handler-name)
+ (or (module-symbol-local-binding
+ duplicate-handlers handler-name #f)
+ (error "invalid duplicate handler name:"
+ handler-name)))
+ (if (list? (cadr kws))
+ (cadr kws)
+ (list (cadr kws)))))
+ (loop (cddr kws) reversed-interfaces exports re-exports))
((#:export #:export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(append (cadr kws) re-exports)))
(else
(unrecognized kws)))))
+ (run-hook module-defined-hook module)
module))
+;; `module-defined-hook' is a hook that is run whenever a new module
+;; is defined. Its members are called with one argument, the new
+;; module.
+(define module-defined-hook (make-hook 1))
+
;;; {Autoload}
(define (make-autoload-interface module name bindings)
;;; {Defmacros}
;;;
-(define macro-table (make-weak-key-hash-table 523))
-(define xformer-table (make-weak-key-hash-table 523))
+(define macro-table (make-weak-key-hash-table 61))
+(define xformer-table (make-weak-key-hash-table 61))
(define (defmacro? m) (hashq-ref macro-table m))
(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
,(make-disable interface))
(defmacro ,(caaddr option-group) (opt val)
`(,,(car options/enable/disable)
- (list ',opt ,val)))))))))
+ (append (,,(car options/enable/disable))
+ (list ',opt ,val))))))))))
(define-option-interface
(eval-options-interface
;; to change scm_c_use_module as well.
(define (process-use-modules module-interface-args)
- (for-each (lambda (mif-args)
- (let ((mod-iface (apply resolve-interface mif-args)))
- (or mod-iface
- (error "no such module" mif-args))
- (module-use! (current-module) mod-iface)))
- module-interface-args))
+ (module-use-interfaces! (current-module)
+ (map (lambda (mif-args)
+ (or (apply resolve-interface mif-args)
+ (error "no such module" mif-args)))
+ module-interface-args)))
(defmacro use-modules modules
`(eval-case
(process-use-modules
(list ,@(map (lambda (m)
`(list ,@(compile-interface-spec m)))
- modules))))
+ modules)))
+ *unspecified*)
(else
(error "use-modules can only be used at the top level"))))
(list ,@(compile-interface-spec spec))))
(set-module-transformer! (current-module)
,(car (last-pair spec))))
- `((set-module-transformer! (current-module) ,spec))))
+ `((set-module-transformer! (current-module) ,spec)))
+ *unspecified*)
(else
(error "use-syntax can only be used at the top level"))))
+;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
+;; as soon as guile supports hygienic macros.
(define define-private define)
(defmacro define-public args
(else
(error "re-export can only be used at the top level"))))
-(define export-syntax export)
-(define re-export-syntax re-export)
+(defmacro export-syntax names
+ `(export ,@names))
+(defmacro re-export-syntax names
+ `(re-export ,@names))
(define load load-module)
\f
+;;; {Handling of duplicate imported bindings}
+;;;
+
+;; Duplicate handlers take the following arguments:
+;;
+;; module importing module
+;; name conflicting name
+;; int1 old interface where name occurs
+;; val1 value of binding in old interface
+;; int2 new interface where name occurs
+;; val2 value of binding in new interface
+;; var previous resolution or #f
+;; val value of previous resolution
+;;
+;; A duplicate handler can take three alternative actions:
+;;
+;; 1. return #f => leave responsibility to next handler
+;; 2. exit with an error
+;; 3. return a variable resolving the conflict
+;;
+
+(define duplicate-handlers
+ (let ((m (make-module 7)))
+ (set-module-name! m 'duplicate-handlers)
+ (set-module-kind! m 'interface)
+ (module-define! m 'check
+ (lambda (module name int1 val1 int2 val2 var val)
+ (scm-error 'misc-error
+ #f
+ "module ~A: duplicate binding ~A imported from ~A and ~A"
+ (list (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #f)))
+ (module-define! m 'first
+ (lambda (module name int1 val1 int2 val2 var val)
+ (or var (module-local-variable int1 name))))
+ (module-define! m 'last
+ (lambda (module name int1 val1 int2 val2 var val)
+ (module-local-variable int2 name)))
+ m))
+
+(define (make-duplicates-interface)
+ (let ((m (make-module)))
+ (set-module-kind! m 'interface)
+ (set-module-name! m 'duplicates)
+ m))
+
+(define (module-symbol-interface module sym)
+ (or-map (lambda (interface)
+ (module-search (lambda (interface sym)
+ (and (module-local-variable interface sym)
+ interface))
+ interface
+ sym))
+ (module-uses module)))
+
+(define (process-duplicates module interface)
+ (let* ((duplicates-info (module-duplicates-info module))
+ (handlers (car duplicates-info))
+ (d-interface (cdr duplicates-info)))
+ (module-for-each
+ (lambda (name var)
+ (let ((prev-interface (module-symbol-interface module name)))
+ (if prev-interface
+ (begin
+ (if (not d-interface)
+ (begin
+ (set! d-interface (make-duplicates-interface))
+ (set-cdr! duplicates-info d-interface)))
+ (let* ((var (module-local-variable d-interface name))
+ (val (and var (variable-bound? var) (variable-ref var))))
+ (let loop ((handlers handlers))
+ (cond ((null? handlers))
+ (((car handlers)
+ module
+ name
+ prev-interface
+ (module-symbol-local-binding prev-interface name #f)
+ interface
+ (module-symbol-local-binding interface name #f)
+ var
+ val)
+ =>
+ (lambda (var)
+ (module-add! d-interface name var)))
+ (else
+ (loop (cdr handlers))))))))))
+ interface)))
+
+\f
;;; {`cond-expand' for SRFI-0 support.}
;;;
HCoop / bpt / guile.git / blobdiff