[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Evolution & optimization of the module system
|
From: |
Ludovic Courtès |
|
Subject: |
Evolution & optimization of the module system |
|
Date: |
Sat, 17 Feb 2007 16:15:11 +0100 |
|
User-agent: |
Gnus/5.110006 (No Gnus v0.6) Emacs/21.4 (gnu/linux) |
Hi,
The patch below (against HEAD) is a proposal to "improve" the module
system in several ways:
1. Remove inconsistencies in how it behaves.
2. Get better documentation and test coverage.
3. Improve performance.
(1) has to do mainly with `module-use!' vs. `module-use-interfaces!' (as
was discussed recently). Namely the fact that duplicate processing is
not always performed, depending on whether one uses `module-use!' or
some other means to use a module. The patch solves this issue by making
duplicate processing inescapable. Likewise, variable lookup currently
has two implementations (which have the same behavior, though): the C
`module_variable ()' and the Scheme `module-variable'. The patch leaves
only one implementation of that.
There's still more to do to achieve (2) (notably actual documentation
;-)) but it's getting better. Hopefully `modules.test' could eventually
cover enough of the API to serve as a "documentation".
(3) is two-fold:
3.a. Duplicate processing.
3.b. Variable lookup.
Although duplicates should be the exception rather than the rule[*],
duplicate processing is pretty costly: the current `process-duplicates'
is roughly O(N*USES), where N is the number of bindings in the interface
to be imported and USES is the number of modules currently used by the
module (because `module-import-interface' is O(USES)).
`module-use-interfaces!' is also terribly costly (calculating its
complexity is left as an exercise to the reader ;-)). Likewise,
variable lookup (e.g., in `module_variable ()') is O(USES). I believe
that both may have a sensible impact on startup time.
The patch addresses this by changing the data structures used by
modules: instead of a list of used modules, it uses a second "obarray",
called the "import obarray", that maps symbols to the modules providing
them. This makes duplicates processing O(N) where N is the number of
bindings in the module to be imported, and variable lookup time is
independent of the number of modules imported. The import obarray is
populated when `module-use!' is invoked (e.g., when `define-module' or
`use-modules' is processed). Because of this, autoloading can no longer
be implemented using `make-autoload-interface' (otherwise, modules would
get loaded immediately, during `process-duplicates'): instead, the new
`module-autoload!' modifies the binder of the user module.
The module system allows bindings to be added dynamically to a module
(e.g., with `module-define!') in such a way that the newly added binding
is immediately visible to the module users. In order to retain these
semantics, modules in the patched version have to "observe" the modules
they use in order to update their "import obarray" upon modification of
the used modules. This is achieved using weak observers where the
observer procedure invokes `process-duplicates' when a used module is
changed.
This has several implications. First, duplicate processing occurs the
same way for dynamically added bindings than for "statically imported"
bindings. Second, it makes load-time-dependent duplicate policies such
as `last' and `first' irrelevant (since they are inherently
non-deterministic). Imagine a module that loads `srfi-34' (after
THE-SCM-MODULE) and then update its import obarray as a result of a
modification in THE-SCM-MODULE: the update will replace the previous
value of `raise' (that from `srfi-34') with the core binding for
`raise'. Third, it makes dynamic addition of bindings relatively
costly. For instance, adding bindings at run-time to THE-SCM-MODULE can
yield to the duplicate processing all already loaded modules.
GOOPS makes use of `module-define!' after `(oop goops)' is used by the
various GOOPS modules, specifically in `create_smob_classes ()' so that
`(oop goops)' exports classes for all SMOB types (`<module>', etc.). In
order to work around this problem, the patch modifies GOOPS so that (1)
`(oop goops)' exports only a predefined set of SMOB classes, and (2) the
SMOB classes are added to a separate module called `(oop goops
smob-classes)'. Since only `(oop goops)' uses it, it is the only one
that needs to re-process duplicates as new SMOB classes are added.
>From a performance viewpoint, the improvement yielded by the new
`process-duplicates' is significant. It can be observed by
(synthetically) creating a new module, having it import hundreds of
modules with tens of bindings, and then invoking:
(module-use-interfaces! m (list the-modules-to-import))
(`module-use-interfaces!' already invokes `process-duplicates' in
current Guile.) From the measurements I've made, the new version is
around 40 times faster than the other one.
The change in variable lookup time can be measured using the worst case,
namely by looking up variables that do not exist in the module---this is
arguably unfair to the current module implementation. Again, there is a
significant difference between both implementations (since the patched
version is almost instantaneous):
(module-ref a-module-that-imports-lots-of-modules (gensym))
However, the module construction cost is much higher with the new data
structure since `beautify-user-module!' has to populate the user
module's import obarray instead of just appending a module to its uses
list. This is optimized by caching a standard module import obarray (in
`%scm-import-obarray') and then simply copying it in
`beautify-user-module!', using the new `hash-table-copy' primitive.
Without `hash-table-copy', the new `beautify-user-module!' is more than
200 times slower than the old one. With `hash-table-copy', it is "only"
100 times slower.
The tiny script at [0] contains tools and instructions to reproduce
these measurements.
So the question is: is the `beautify-user-module!' overhead compensated
by the variable lookup and duplicate processing gains?
An application of mine [1], although it modifies `the-scm-module' at
run-time, requiring 40 modules to re-process duplicates, has its
execution time reduced by 8% (on a run that loads around 100 modules).
The whole test suite runs about 10% faster with the modified version
(although it has a larger `modules.test'). So it seems to be beneficial
performance-wise. I'd be happy if people could try it out with other
applications (e.g., Lilypond ;-)) and measure the difference it makes.
Algorithmically, the module system could be further optimized by
removing the use list computation from `module-use!' (the use list is
used by `cond-expand', but `module-uses' could be implemented by
traversing the module obarray). It could also be "micro-optimized" by
removing the "eval closure" indirection since it does not seem to be
useful.
I hope this long email will lead to a warm discussion! :-)
Thanks,
Ludovic.
PS: The patch is still drafty.
[*] R6RS libraries _disallow_ duplicate binding imports:
http://www.r6rs.org/document/html/r6rs-Z-H-2.html#node_toc_node_sec_6.1
[0] http://www.laas.fr/~lcourtes/software/guile/module-duplicates.scm
[1] http://www.nongnu.org/skribilo/
--- orig/ice-9/boot-9.scm
+++ mod/ice-9/boot-9.scm
@@ -1100,8 +1100,6 @@
;;;
;;; - duplicates-handlers
;;;
-;;; - duplicates-interface
-;;;
;;; - observers
;;;
;;; - weak-observers
@@ -1173,8 +1171,10 @@
(define module-type
(make-record-type 'module
'(obarray uses binder eval-closure transformer name kind
- duplicates-handlers duplicates-interface
- observers weak-observers observer-id)
+ duplicates-handlers
+ duplicates-interface ;; FIXME: to be removed
+ observers weak-observers observer-id
+ import-obarray)
%print-module))
;; make-module &opt size uses binder
@@ -1190,6 +1190,10 @@
(list-ref args index)
default))
+ (define %default-import-size
+ ;; This should be the size of the pre-module obarray.
+ 500)
+
(if (> (length args) 3)
(error "Too many args to make-module." args))
@@ -1209,8 +1213,9 @@
(let ((module (module-constructor (make-hash-table size)
uses binder #f #f #f #f #f #f
'()
- (make-weak-value-hash-table 31)
- 0)))
+ (make-weak-key-hash-table 31)
+ 0
+ (make-hash-table
%default-import-size))))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
@@ -1240,10 +1245,6 @@
(record-accessor module-type 'duplicates-handlers))
(define set-module-duplicates-handlers!
(record-modifier module-type 'duplicates-handlers))
-(define module-duplicates-interface
- (record-accessor module-type 'duplicates-interface))
-(define set-module-duplicates-interface!
- (record-modifier module-type 'duplicates-interface))
(define module-observers (record-accessor module-type 'observers))
(define set-module-observers! (record-modifier module-type 'observers))
(define module-weak-observers (record-accessor module-type 'weak-observers))
@@ -1251,6 +1252,9 @@
(define set-module-observer-id! (record-modifier module-type 'observer-id))
(define module? (record-predicate module-type))
+(define module-import-obarray (record-accessor module-type 'import-obarray))
+(define set-module-import-obarray! (record-modifier module-type
'import-obarray))
+
(define set-module-eval-closure!
(let ((setter (record-modifier module-type 'eval-closure)))
(lambda (module closure)
@@ -1269,11 +1273,10 @@
(set-module-observers! module (cons proc (module-observers module)))
(cons module proc))
-(define (module-observe-weak module proc)
- (let ((id (module-observer-id module)))
- (hash-set! (module-weak-observers module) id proc)
- (set-module-observer-id! module (+ 1 id))
- (cons module id)))
+(define (module-observe-weak module observer-id . proc)
+ (let ((id (if (null? proc) (gensym) observer-id))
+ (proc (if (null? proc) observer-id (car proc))))
+ (hashq-set! (module-weak-observers module) observer-id proc)))
(define (module-unobserve token)
(let ((module (car token))
@@ -1311,7 +1314,11 @@
(define (module-call-observers m)
(for-each (lambda (proc) (proc m)) (module-observers m))
- (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
+
+ ;; We assume that weak observers don't (un)register themselves as they are
+ ;; called since this would preclude proper iteration over the hash table
+ ;; elements.
+ (hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m)))
@@ -1435,26 +1442,8 @@
;;;
;;; If the symbol is not found at all, return #f.
;;;
-(define (module-local-variable m v)
-; (caddr
-; (list m v
- (let ((b (module-obarray-ref (module-obarray m) v)))
- (or (and (variable? b) b)
- (and (module-binder m)
- ((module-binder m) m v #f)))))
-;))
-
-;; module-variable module symbol
-;;
-;; like module-local-variable, except search the uses in the
-;; case V is not found in M.
-;;
-;; NOTE: This function is superseded with C code (see modules.c)
-;;; when using the standard eval closure.
-;;
-(define (module-variable m v)
- (module-search module-local-variable m v))
-
+;;; (This is now written in C, see `modules.c'.)
+;;;
;;; {Mapping modules x symbols --> bindings}
;;;
@@ -1515,19 +1504,10 @@
(module-modified m)
b)))
- ;; No local variable yet, so we need to create a new one. That
- ;; new variable is initialized with the old imported value of V,
- ;; if there is one.
- (let ((imported-var (module-variable m v))
- (local-var (or (and (module-binder m)
- ((module-binder m) m v #t))
- (begin
- (let ((answer (make-undefined-variable)))
- (module-add! m v answer)
- answer)))))
- (if (and imported-var (not (variable-bound? local-var)))
- (variable-set! local-var (variable-ref imported-var)))
- local-var)))
+ ;; Create a new local variable.
+ (let ((local-var (make-undefined-variable)))
+ (module-add! m v local-var)
+ local-var)))
;; module-ensure-local-variable! module symbol
;;
@@ -1696,46 +1676,41 @@
;; Add INTERFACE to the list of interfaces used by MODULE.
;;
(define (module-use! module interface)
- (set-module-uses! module
- (cons interface
- (filter (lambda (m)
- (not (equal? (module-name m)
- (module-name interface))))
- (module-uses module))))
- (module-modified module))
+ ;; Perform duplicate checking, thereby populating the `import-obarray' of
+ ;; MODULE.
+ (if (not (eq? module interface))
+ (begin
+ (process-duplicates module interface)
+
+ (set-module-uses! module
+ (cons interface
+ (filter (lambda (m)
+ (not
+ (equal? (module-name m)
+ (module-name interface))))
+ (module-uses module))))
+
+ ;; Prepare to update MODULE's import obarray when INTERFACE changes.
+ ;; This can happen if dynamic module modification features like
+ ;; `module-define!' are used, but also, more commonly, in the case of
+ ;; mutually dependent modules (circular dependency).
+ (module-observe-weak interface module
+ (lambda (interface)
+ ;;(format (current-error-port)
+ ;; "iface ~a changed, updating module
~a~%"
+ ;; interface module)
+ (process-duplicates module interface)))
+
+ (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-handlers? (or (module-duplicates-handlers module)
- (default-duplicate-binding-procedures)))
- (uses (module-uses module)))
- ;; remove duplicates-interface
- (set! uses (delq! (module-duplicates-interface module) uses))
- ;; remove interfaces to be added
- (for-each (lambda (interface)
- (set! uses
- (filter (lambda (m)
- (not (equal? (module-name m)
- (module-name 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 (module-duplicates-interface module)
- (set-module-uses! module
- (cons (module-duplicates-interface module) uses)))
- (module-modified module)))
+ (for-each (lambda (interface)
+ (module-use! module interface))
+ interfaces))
@@ -1861,8 +1836,20 @@
(set-module-public-interface! module interface))))
(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)))))
+ ;; Import the default set of bindings (from the SCM module) in MODULE
+ ;; and process duplicates between the SCM module and MODULE.
+ (begin
+ ;; Copy the pre-compiled import obarray for `the-scm-module'. This
+ ;; is twice as fast as populating a new hash table by iterating over
+ ;; the bindings of `the-scm-module'.
+ (set-module-import-obarray! module
+ (hash-table-copy %scm-import-obarray))
+ (module-observe-weak the-scm-module module
+ (lambda (interface)
+ ;;(format (current-error-port)
+ ;; "~%~%root module changed, updating
module ~a~%"
+ ;; module)
+ (process-duplicates module interface))))))
;; NOTE: This binding is used in libguile/modules.c.
;;
@@ -2007,6 +1994,10 @@
#f "no binding `~A' to hide in module ~A"
binding name))))
hide)
+
+ ;; XXX: Such modules are _not_ updated when the interfaces they use
+ ;; are modified!
+
custom-i))))
(define (symbol-prefix-proc prefix)
@@ -2027,7 +2018,8 @@
(reversed-interfaces '())
(exports '())
(re-exports '())
- (replacements '()))
+ (replacements '())
+ (autoloads '()))
(if (null? kws)
(call-with-deferred-observers
@@ -2035,7 +2027,9 @@
(module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports)
(module-replace! module replacements)
- (module-re-export! module re-exports)))
+ (module-re-export! module re-exports)
+ (if (not (null? autoloads))
+ (apply module-autoload! module autoloads))))
(case (car kws)
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
@@ -2055,31 +2049,35 @@
(cons interface reversed-interfaces)
exports
re-exports
- replacements)))
+ replacements
+ autoloads)))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
(loop (cdddr kws)
- (cons (make-autoload-interface module
- (cadr kws)
- (caddr kws))
- reversed-interfaces)
+ reversed-interfaces
exports
re-exports
- replacements))
+ replacements
+ (let ((name (cadr kws))
+ (bindings (caddr kws)))
+ (cons* name bindings autoloads))))
((#:no-backtrace)
(set-system-module! module #t)
- (loop (cdr kws) reversed-interfaces exports re-exports
replacements))
+ (loop (cdr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:pure)
(purify-module! module)
- (loop (cdr kws) reversed-interfaces exports re-exports
replacements))
+ (loop (cdr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
(set-module-duplicates-handlers!
module
(lookup-duplicates-handlers (cadr kws)))
- (loop (cddr kws) reversed-interfaces exports re-exports
replacements))
+ (loop (cddr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:export #:export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@@ -2087,7 +2085,8 @@
reversed-interfaces
(append (cadr kws) exports)
re-exports
- replacements))
+ replacements
+ autoloads))
((#:re-export #:re-export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@@ -2095,7 +2094,8 @@
reversed-interfaces
exports
(append (cadr kws) re-exports)
- replacements))
+ replacements
+ autoloads))
((#:replace #:replace-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@@ -2103,7 +2103,8 @@
reversed-interfaces
exports
re-exports
- (append (cadr kws) replacements)))
+ (append (cadr kws) replacements)
+ autoloads))
(else
(unrecognized kws)))))
(run-hook module-defined-hook module)
@@ -2119,20 +2120,64 @@
;;; {Autoload}
;;;
-(define (make-autoload-interface module name bindings)
- (let ((b (lambda (a sym definep)
- (and (memq sym bindings)
- (let ((i (module-public-interface (resolve-module name))))
- (if (not i)
- (error "missing interface for module" name))
- (let ((autoload (memq a (module-uses module))))
- ;; Replace autoload-interface with actual interface if
- ;; that has not happened yet.
- (if (pair? autoload)
- (set-car! autoload i)))
- (module-local-variable i sym))))))
- (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
- '() (make-weak-value-hash-table 31) 0)))
+(define (module-autoload! module . name+binding)
+ "Have @var{module} autoload the given module for the specified bindings.
+For instance, @code{(module-autoload! m '(ice-9 debugger) '(debug))} results
+in @var{m} autoloading module @code{(ice-9 debugger)} whenever binding
address@hidden is accessed."
+
+ (define (binding->name-alist name+binding)
+ (let loop ((binding->name '())
+ (name+binding name+binding))
+ (if (null? name+binding)
+ binding->name
+ (let ((module-name (car name+binding))
+ (bindings (cadr name+binding)))
+ (loop (append (map (lambda (binding)
+ (cons binding module-name))
+ bindings)
+ binding->name)
+ (cddr name+binding))))))
+
+ (let* ((binding-alist (binding->name-alist name+binding))
+ (binder (module-binder module))
+ (new-binder
+ (lambda (a sym define?)
+ (or (and (procedure? binder)
+ (binder a sym define?))
+ (let* ((bind (assq sym binding-alist))
+ (module-name (and (pair? bind) (cdr bind))))
+ (and module-name
+ (let ((i (module-public-interface
+ (resolve-module module-name))))
+ (if (not i)
+ (error "missing interface for module" name))
+
+ ;;(format #t "autoloaded ~a for ~a because of ~a~%"
+ ;; module-name module sym)
+
+ (set! binding-alist
+ (assq-remove! binding-alist sym))
+ (module-use-interfaces! module (list i))
+
+ (module-variable i sym))))))))
+
+ ;; Make sure the given bindings are not already imported. This allows
+ ;; autoloading to work even when the triggering symbols would replace
+ ;; already existing bindings. IOW, this sets a special duplicate
+ ;; handling policy where the explicitly autoloaded symbols override other
+ ;; same-named imported symbols.
+ (let ((imports (module-import-obarray module)))
+ (let loop ((name+binding name+binding))
+ (if (not (null? name+binding))
+ (let ((bindings (cadr name+binding)))
+ (for-each (lambda (autoloaded-binding)
+ (hashq-set! imports autoloaded-binding #f))
+ bindings)
+ (loop (cddr name+binding))))))
+
+ ;; Install the new binder.
+ (set-module-binder! module new-binder)))
;;; {Compiled module}
@@ -3133,34 +3178,38 @@
(lookup-duplicates-handlers handler-names))
handler-names)))
-(define (make-duplicates-interface)
- (let ((m (make-module)))
- (set-module-kind! m 'custom-interface)
- (set-module-name! m 'duplicates)
- m))
-
(define (process-duplicates module interface)
+ ;; Process duplicate bindings as MODULE imports INTERFACE (typically a
+ ;; module's public interface).
+
+ (define (%module-for-each proc module)
+ ;; Some modules re-export bindings from other modules. They do so by
+ ;; having the public interface import the public interface of those other
+ ;; bindings (see, e.g., `(oop goops internal)'). Thus, we must traverse
+ ;; both bindings internal to INTERFACE and bindings _imported_ by
+ ;; INTERFACE.
+ (hash-for-each proc (module-obarray module))
+ (hash-for-each (lambda (sym interface)
+ (let ((var (module-variable interface sym)))
+ (if (not var)
+ (format (current-error-port) "`~a' from `~a' =>
~a~%"
+ sym interface var))
+ (proc sym var)))
+ (module-import-obarray module)))
+
(let* ((duplicates-handlers (or (module-duplicates-handlers module)
(default-duplicate-binding-procedures)))
- (duplicates-interface (module-duplicates-interface module)))
- (module-for-each
+ (imports (module-import-obarray module)))
+ (%module-for-each
(lambda (name var)
- (cond ((module-import-interface module name)
+ (cond ((hashq-ref imports name)
=>
(lambda (prev-interface)
- (let ((var1 (module-local-variable prev-interface name))
- (var2 (module-local-variable interface name)))
+ (let ((var1 (module-variable prev-interface name))
+ (var2 (module-variable interface name)))
(if (not (eq? var1 var2))
(begin
- (if (not duplicates-interface)
- (begin
- (set! duplicates-interface
- (make-duplicates-interface))
- (set-module-duplicates-interface!
- module
- duplicates-interface)))
- (let* ((var (module-local-variable duplicates-interface
- name))
+ (let* ((var var1)
(val (and var
(variable-bound? var)
(variable-ref var))))
@@ -3179,9 +3228,14 @@
val)
=>
(lambda (var)
- (module-add! duplicates-interface name
var)))
+ (hashq-set! imports name
+ (if (eq? var1 var)
+ prev-interface
+ interface))))
(else
- (loop (cdr duplicates-handlers)))))))))))))
+ (loop (cdr duplicates-handlers)))))))))))
+ (else
+ (hashq-set! imports name interface))))
interface)))
@@ -3398,10 +3452,7 @@
'(((ice-9 threads)))
'())))
;; load debugger on demand
- (module-use! guile-user-module
- (make-autoload-interface guile-user-module
- '(ice-9 debugger) '(debug)))
-
+ (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
@@ -3477,6 +3528,30 @@
+(define %scm-import-obarray
+ ;; A pre-compiled "import obarray" for use by modules that use
+ ;; `the-scm-module'. This allows to halve the time spent in
+ ;; `beautify-user-module!'.
+ (begin
+ (define (make-scm-import-obarray)
+ (let ((imports (make-hash-table 2000)))
+ (module-for-each (lambda (sym var)
+ (hashq-set! imports sym the-scm-module))
+ the-scm-module)
+ imports))
+
+ (module-observe-weak the-scm-module #t
+ (lambda (interface)
+ ;; Update it.
+ (format (current-error-port)
+ "updating `%scm-import-obarray'~%")
+ (set! %scm-import-obarray
+ (make-scm-import-obarray))))
+
+ (make-scm-import-obarray)))
+
+
+
;;; Place the user in the guile-user module.
;;;
--- orig/libguile/goops.c
+++ mod/libguile/goops.c
@@ -2587,10 +2587,14 @@
*
**********************************************************************/
+/* A module holding SMOB classes. */
+static SCM smob_class_module = SCM_UNSPECIFIED;
+
static SCM
make_class_from_template (char const *template, char const *type_name, SCM
supers, int applicablep)
{
SCM class, name;
+
if (type_name)
{
char buffer[100];
@@ -2609,8 +2613,12 @@
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
- && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name,
SCM_BOOL_F)))
- DEFVAR (name, class);
+ && scm_is_false (scm_module_local_variable (smob_class_module, name)))
+ {
+ scm_module_define (smob_class_module, name, class);
+ scm_module_export (smob_class_module, scm_list_1 (name));
+ }
+
return class;
}
@@ -2665,6 +2673,11 @@
{
long i;
+ /* Create the module that will hold the SMOB classes. */
+ smob_class_module = scm_c_define_module ("oop goops smob-classes",
+ NULL, NULL);
+ smob_class_module = scm_permanent_object (smob_class_module);
+
scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
for (i = 0; i < 255; ++i)
scm_smob_class[i] = 0;
--- orig/libguile/hashtab.c
+++ mod/libguile/hashtab.c
@@ -76,37 +76,65 @@
#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
+static inline unsigned long
+find_suitable_bucket_count (unsigned long element_count, int *size_index)
+{
+ unsigned i = 0;
+
+ while (i < HASHTABLE_SIZE_N && element_count > hashtable_size[i])
+ ++i;
+
+ *size_index = i;
+
+ return (hashtable_size[i]);
+}
+
+
static char *s_hashtable = "hashtable";
SCM weak_hashtables = SCM_EOL;
+static inline SCM
+make_hash_table_from_buckets (SCM buckets, scm_t_hashtable *c_table, int flags)
+{
+ SCM table, link;
+
+ if (flags)
+ link = weak_hashtables;
+ else
+ link = SCM_EOL;
+
+ SCM_NEWSMOB3 (table, scm_tc16_hashtable, buckets, c_table, link);
+
+ if (flags)
+ weak_hashtables = table;
+
+ return table;
+}
+
static SCM
make_hash_table (int flags, unsigned long k, const char *func_name)
{
SCM table, vector;
scm_t_hashtable *t;
- int i = 0, n = k ? k : 31;
- while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
- ++i;
- n = hashtable_size[i];
+ int size_index = 0, n = k ? k : 31;
+
+ n = find_suitable_bucket_count (k, &size_index);
+
if (flags)
vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
else
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc (sizeof (*t), s_hashtable);
- t->min_size_index = t->size_index = i;
+ t->min_size_index = t->size_index = size_index;
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
t->flags = flags;
t->hash_fn = NULL;
- if (flags)
- {
- SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
- weak_hashtables = table;
- }
- else
- SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
+
+ table = make_hash_table_from_buckets (vector, t, flags);
+
return table;
}
@@ -309,6 +337,71 @@
}
#undef FUNC_NAME
+/* Copy the given alist, i.e., duplicate all its pairs recursively. */
+static inline SCM
+alist_copy (SCM alist)
+{
+ SCM it, pair, result = SCM_EOL;
+
+ for (it = alist;
+ !scm_is_null (it);
+ it = SCM_CDR (it))
+ {
+ pair = SCM_CAR (it);
+ result = scm_cons (scm_cons (SCM_CAR (pair), SCM_CDR (pair)),
+ result);
+ }
+
+ return result;
+}
+
+SCM_DEFINE (scm_hash_table_copy, "hash-table-copy", 1, 0, 0,
+ (SCM table),
+ "Return a newly allocated hash table whose contents are the "
+ "same as those of @var{hashtab}. This should be faster than "
+ "traversing @var{table} and invoking @code{hash-set!} on a "
+ "new (empty) table for each element since the new table will "
+ "be readily balanced.")
+#define FUNC_NAME s_scm_hash_table_copy
+{
+ size_t bucket_count, i;
+ scm_t_hashtable *c_new_table = NULL;
+ SCM buckets, new_buckets, new_table;
+
+ if (SCM_HASHTABLE_P (table))
+ {
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ c_new_table = scm_gc_malloc (sizeof (* c_new_table), s_hashtable);
+ }
+ else
+ {
+ SCM_VALIDATE_VECTOR (1, table);
+ buckets = table;
+ }
+
+ bucket_count = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ new_buckets = scm_c_make_vector (bucket_count, SCM_BOOL_F);
+
+ for (i = 0; i < bucket_count; i++)
+ {
+ SCM alist;
+
+ alist = alist_copy (SCM_SIMPLE_VECTOR_REF (buckets, i));
+ SCM_SIMPLE_VECTOR_SET (new_buckets, i, alist);
+ }
+
+ if (SCM_HASHTABLE_P (table))
+ {
+ *c_new_table = *SCM_HASHTABLE (table);
+ new_table = make_hash_table_from_buckets (new_buckets, c_new_table, 0);
+ }
+ else
+ new_table = new_buckets;
+
+ return new_table;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
(SCM n),
"@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
@@ -409,6 +502,9 @@
#undef FUNC_NAME
+
+/* Accessors. */
+
SCM
scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM
(*assoc_fn)(), void * closure)
#define FUNC_NAME "scm_hash_fn_get_handle"
--- orig/libguile/modules.c
+++ mod/libguile/modules.c
@@ -162,12 +162,8 @@
static SCM module_export_x_var;
-
-/*
- TODO: should export this function? --hwn.
- */
-static SCM
-scm_export (SCM module, SCM namelist)
+SCM
+scm_module_export (SCM module, SCM namelist)
{
return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
module, namelist);
@@ -203,7 +199,7 @@
tail = SCM_CDRLOC (*tail);
}
va_end (ap);
- scm_export (scm_current_module(), names);
+ scm_module_export (scm_current_module (), names);
}
}
@@ -280,40 +276,113 @@
static SCM module_make_local_var_x_var;
-static SCM
-module_variable (SCM module, SCM sym)
+SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
+ (SCM module, SCM sym),
+ "Return the variable bound to @var{sym} in @var{module}. Return "
+ "@code{#f} is @var{sym} is not bound locally in @var{module}.")
+#define FUNC_NAME s_scm_module_local_variable
{
#define SCM_BOUND_THING_P(b) \
(scm_is_true (b))
+ register SCM b;
+
+ /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
+ evaluated. */
+ if (scm_module_system_booted_p)
+ SCM_VALIDATE_MODULE (1, module);
+
+ SCM_VALIDATE_SYMBOL (2, sym);
+
+
/* 1. Check module obarray */
- SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
+ b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (b))
return b;
+
+ /* 2. Search imported bindings. In order to be consistent with
+ `module-variable', the binder gets called only when no imported binding
+ matches SYM. */
+ b = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_UNDEFINED);
+ if (SCM_BOUND_THING_P (b))
+ return SCM_BOOL_F;
+
{
+ /* 3. Query the custom binder. */
SCM binder = SCM_MODULE_BINDER (module);
+
if (scm_is_true (binder))
- /* 2. Custom binder */
{
b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b))
return b;
}
}
+
+ return SCM_BOOL_F;
+
+#undef SCM_BOUND_THING_P
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
+ (SCM module, SCM sym),
+ "Return the variable bound to @var{sym} in @var{module}. This "
+ "may be both a local variable or an imported variable. Return "
+ "@code{#f} is @var{sym} is not bound in @var{module}.")
+#define FUNC_NAME s_scm_module_variable
+{
+ SCM_VALIDATE_MODULE (1, module);
+ SCM_VALIDATE_SYMBOL (2, sym);
+
+#define SCM_BOUND_THING_P(b) \
+ (scm_is_true (b))
+
+ /* 1. Check module obarray */
+ register SCM b, binder;
+
+ lookup:
+ binder = SCM_MODULE_BINDER (module);
+
+ b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
+ if (SCM_BOUND_THING_P (b))
+ return b;
+
+ {
+ /* 2. Search imported bindings. */
+ SCM iface, imports = SCM_MODULE_IMPORT_OBARRAY (module);
+
+ iface = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
+ if (SCM_MODULEP (iface))
+ {
+ if (scm_is_false (binder))
+ {
+ /* Tail-recursive call. */
+ module = iface;
+ goto lookup;
+ }
+
+ b = scm_module_variable (iface, sym);
+ if (SCM_BOUND_THING_P (b))
+ return b;
+ }
+ }
+
{
- /* 3. Search the use list */
- SCM uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
+ /* 3. Query the custom binder. */
+ if (scm_is_true (binder))
{
- b = module_variable (SCM_CAR (uses), sym);
+ b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b))
return b;
- uses = SCM_CDR (uses);
}
- return SCM_BOOL_F;
}
+
+ return SCM_BOOL_F;
+
#undef SCM_BOUND_THING_P
}
+#undef FUNC_NAME
scm_t_bits scm_tc16_eval_closure;
@@ -335,7 +404,7 @@
module, sym);
}
else
- return module_variable (module, sym);
+ return scm_module_variable (module, sym);
}
SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
@@ -398,38 +467,16 @@
SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
(SCM module, SCM sym),
- "")
+ "Return the module or interface from which @var{sym} is imported "
+ "in @var{module}. If @var{sym} is not imported (i.e., it is not "
+ "defined in @var{module} or it is a module-local binding instead "
+ "of an imported one), then @code{#f} is returned.")
#define FUNC_NAME s_scm_module_import_interface
{
-#define SCM_BOUND_THING_P(b) (scm_is_true (b))
- SCM uses;
- SCM_VALIDATE_MODULE (SCM_ARG1, module);
- /* Search the use list */
- uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
- {
- SCM _interface = SCM_CAR (uses);
- /* 1. Check module obarray */
- SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
- if (SCM_BOUND_THING_P (b))
- return _interface;
- {
- SCM binder = SCM_MODULE_BINDER (_interface);
- if (scm_is_true (binder))
- /* 2. Custom binder */
- {
- b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
- if (SCM_BOUND_THING_P (b))
- return _interface;
- }
- }
- /* 3. Search use list recursively. */
- _interface = scm_module_import_interface (_interface, sym);
- if (scm_is_true (_interface))
- return _interface;
- uses = SCM_CDR (uses);
- }
- return SCM_BOOL_F;
+ SCM_VALIDATE_MODULE (1, module);
+ SCM_VALIDATE_SYMBOL (2, sym);
+
+ return (scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F));
}
#undef FUNC_NAME
@@ -560,52 +607,76 @@
return var;
}
-SCM
-scm_module_reverse_lookup (SCM module, SCM variable)
-#define FUNC_NAME "module-reverse-lookup"
+SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
+ (SCM module, SCM variable),
+ "Return the symbol under which @var{variable} is bound in "
+ "@var{module} or @var{#f} if @var{variable} is not visible "
+ "from @var{module}. If @var{module} is @code{#f}, then the "
+ "pre-module obarray is used.")
+#define FUNC_NAME s_scm_module_reverse_lookup
{
- SCM obarray;
- long i, n;
+ unsigned long i, n;
+ SCM obarray, import_obarray;
if (scm_is_false (module))
- obarray = scm_pre_modules_obarray;
+ {
+ obarray = scm_pre_modules_obarray;
+ import_obarray = SCM_BOOL_F;
+ }
else
{
SCM_VALIDATE_MODULE (1, module);
obarray = SCM_MODULE_OBARRAY (module);
+ import_obarray = SCM_MODULE_IMPORT_OBARRAY (module);
}
- if (!SCM_HASHTABLE_P (obarray))
- return SCM_BOOL_F;
-
- /* XXX - We do not use scm_hash_fold here to avoid searching the
- whole obarray. We should have a scm_hash_find procedure. */
+ SCM_VALIDATE_VARIABLE (2, variable);
+ /* Search the module's obarray.
+ XXX - We do not use scm_hash_fold here to avoid searching the whole
+ obarray. We should have a scm_hash_find procedure. */
n = SCM_HASHTABLE_N_BUCKETS (obarray);
for (i = 0; i < n; ++i)
{
- SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
- while (!scm_is_null (ls))
+ SCM handle, ls;
+
+ for (ls = SCM_HASHTABLE_BUCKET (obarray, i);
+ !scm_is_null (ls);
+ ls = SCM_CDR (ls))
{
handle = SCM_CAR (ls);
if (SCM_CDR (handle) == variable)
return SCM_CAR (handle);
- ls = SCM_CDR (ls);
}
}
- /* Try the `uses' list.
- */
- {
- SCM uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
- {
- SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
- if (scm_is_true (sym))
- return sym;
- uses = SCM_CDR (uses);
- }
- }
+ if (scm_is_true (import_obarray))
+ {
+ /* Now, search the import obarray (which requires some more work). */
+ n = SCM_HASHTABLE_N_BUCKETS (import_obarray);
+ for (i = 0; i < n; ++i)
+ {
+ SCM handle, iface, ls;
+
+ for (ls = SCM_HASHTABLE_BUCKET (import_obarray, i);
+ !scm_is_null (ls);
+ ls = SCM_CDR (ls))
+ {
+ handle = SCM_CAR (ls);
+ iface = SCM_CDR (handle);
+ if (SCM_MODULEP (iface))
+ {
+ SCM sym, var;
+
+ sym = SCM_CAR (handle);
+ var = scm_module_variable (iface, sym);
+
+ if (scm_is_eq (var, variable))
+ return sym;
+ }
+ }
+ }
+ }
return SCM_BOOL_F;
}
--- orig/libguile/modules.h
+++ mod/libguile/modules.h
@@ -45,6 +45,7 @@
#define scm_module_index_binder 2
#define scm_module_index_eval_closure 3
#define scm_module_index_transformer 4
+#define scm_module_index_import_obarray 12
#define SCM_MODULE_OBARRAY(module) \
SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray])
@@ -56,6 +57,8 @@
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure])
#define SCM_MODULE_TRANSFORMER(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer])
+#define SCM_MODULE_IMPORT_OBARRAY(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_import_obarray])
SCM_API scm_t_bits scm_tc16_eval_closure;
@@ -64,6 +67,8 @@
SCM_API SCM scm_current_module (void);
+SCM_API SCM scm_module_variable (SCM module, SCM sym);
+SCM_API SCM scm_module_local_variable (SCM module, SCM sym);
SCM_API SCM scm_interaction_environment (void);
SCM_API SCM scm_set_current_module (SCM module);
@@ -80,6 +85,7 @@
SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val);
SCM_API SCM scm_module_lookup (SCM module, SCM symbol);
SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val);
+SCM_API SCM scm_module_export (SCM module, SCM symbol_list);
SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);
SCM_API SCM scm_c_resolve_module (const char *name);
--- orig/oop/goops.scm
+++ mod/oop/goops.scm
@@ -85,7 +85,67 @@
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops dispatch)
- (oop goops compile))
+ (oop goops compile)
+ (oop goops smob-classes))
+
+;; Re-export the SMOB classes defined in the `smob-classes' module. The
+;; `smob-classes' module is a "virtual" module created and populated by
+;; `create_smob_classes ()'.
+
+(re-export ;; FIXME: We certainly don't need all of them.
+<free>
+<fluid>
+<dynamic-state>
+<hashtable>
+<continuation>
+<thread>
+<mutex>
+<condition-variable>
+<arbiter>
+<async>
+<frame>
+<winder>
+<hook>
+;;<allocated cell>
+<macro>
+<malloc>
+<eval-closure>
+<directory>
+<regexp>
+<srcprops>
+<character-set>
+<jmpbuffer>
+<pre-unwind-data>
+<guardian>
+<promise>
+<memoized>
+<debug-object>
+<random-state>
+<array>
+<enclosed-array>
+<bitvector>
+<dynamic-object>
+<uvec>
+<stack>
+<print-state>
+<module>
+<file-port>
+<file-input-port>
+<file-output-port>
+<file-input-output-port>
+<string-port>
+<string-input-port>
+<string-output-port>
+<string-input-output-port>
+<void-port>
+<void-input-port>
+<void-output-port>
+<void-input-output-port>
+<soft-port>
+<soft-input-port>
+<soft-output-port>
+<soft-input-output-port>)
+
(define min-fixnum (- (expt 2 29)))
--- orig/oop/goops/internal.scm
+++ mod/oop/goops/internal.scm
@@ -21,5 +21,10 @@
(define-module (oop goops internal)
:use-module (oop goops))
-(set-module-uses! %module-public-interface
- (list (nested-ref the-root-module '(app modules oop goops))))
+;; Export all the bindings that are internal to `(oop goops)'.
+(let ((public-i (module-public-interface (current-module))))
+ (module-for-each (lambda (name var)
+ (if (eq? name '%module-public-interface)
+ #t
+ (module-add! public-i name var)))
+ (resolve-module '(oop goops))))
--- orig/srfi/srfi-34.scm
+++ mod/srfi/srfi-34.scm
@@ -27,8 +27,8 @@
;;; Code:
(define-module (srfi srfi-34)
- #:export (with-exception-handler
- raise)
+ #:export (with-exception-handler)
+ #:replace (raise)
#:export-syntax (guard))
(cond-expand-provide (current-module) '(srfi-34))
--- orig/test-suite/tests/hash.test
+++ mod/test-suite/tests/hash.test
@@ -72,3 +72,37 @@
(hashx-set! hashq assq table 'x 123)
(hashx-remove! hashq assq table 'x)
(null? (hash-map->list noop table)))))
+
+;;;
+;;; hash-table-copy
+;;;
+
+(with-test-prefix "hash-table-copy"
+
+ (pass-if "hash-table"
+ (let ((table (make-hash-table))
+ (pair<? (lambda (p1 p2)
+ (< (cdr p1) (cdr p2)))))
+ (hashq-set! table 'hello 1)
+ (hashq-set! table 'world 2)
+ (hashq-set! table '! 3)
+ (let ((new-table (hash-table-copy table)))
+ (and (hash-table? new-table)
+ (not (eq? (hashq-get-handle table 'hello)
+ (hashq-get-handle new-table 'hello)))
+ (equal? (sort (hash-map->list cons table) pair<?)
+ (sort (hash-map->list cons new-table) pair<?))))))
+
+ (pass-if "vector"
+ (let ((table (make-vector 33 '()))
+ (pair<? (lambda (p1 p2)
+ (< (cdr p1) (cdr p2)))))
+ (hashq-set! table 'hello 1)
+ (hashq-set! table 'world 2)
+ (hashq-set! table '! 3)
+ (let ((new-table (hash-table-copy table)))
+ (and (vector? new-table)
+ (not (eq? (hashq-get-handle table 'hello)
+ (hashq-get-handle new-table 'hello)))
+ (equal? (sort (hash-map->list cons table) pair<?)
+ (sort (hash-map->list cons new-table) pair<?)))))))
--- orig/test-suite/tests/modules.test
+++ mod/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
-;;;; Copyright (C) 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -16,10 +16,268 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(use-modules (test-suite lib))
+(define-module (test-suite test-modules)
+ :use-module (srfi srfi-1)
+ :use-module ((ice-9 streams) ;; for test purposes
+ #:renamer (symbol-prefix-proc 's:))
+ :use-module (test-suite lib))
+
+
+(define (every? . args)
+ (not (not (apply every args))))
+
+
+
+;;;
+;;; Foundations.
+;;;
+
+(with-test-prefix "foundations"
+
+ (pass-if "module-add!"
+ (let ((m (make-module))
+ (value (cons 'x 'y)))
+ (module-add! m 'something (make-variable value))
+ (eq? (module-ref m 'something) value)))
+
+ (pass-if "module-define!"
+ (let ((m (make-module))
+ (value (cons 'x 'y)))
+ (module-define! m 'something value)
+ (eq? (module-ref m 'something) value)))
+
+ (pass-if "module-use!"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something 'something)
+ (module-define! import 'imported 'imported)
+ (module-use! m import)
+ (and (eq? (module-ref m 'something) 'something)
+ (eq? (module-ref m 'imported) 'imported)
+ (module-local-variable m 'something)
+ (not (module-local-variable m 'imported))
+ #t)))
+
+ (pass-if "module-use! (duplicates local binding)"
+ ;; Imported bindings can't override locale bindings.
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something 'something)
+ (module-define! import 'something 'imported)
+ (module-use! m import)
+ (eq? (module-ref m 'something) 'something)))
+
+ (pass-if "module-locally-bound?"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something #t)
+ (module-define! import 'imported #t)
+ (module-use! m import)
+ (and (module-locally-bound? m 'something)
+ (not (module-locally-bound? m 'imported)))))
+
+ (pass-if "module-{local-,}variable"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'local #t)
+ (module-define! import 'imported #t)
+ (module-use! m import)
+ (and (module-local-variable m 'local)
+ (not (module-local-variable m 'imported))
+ (eq? (module-variable m 'local)
+ (module-local-variable m 'local))
+ (eq? (module-local-variable import 'imported)
+ (module-variable m 'imported)))))
+
+ (pass-if "module-import-interface"
+ (and (every? (lambda (sym iface)
+ (eq? (module-import-interface (current-module) sym)
+ iface))
+ '(current-module exception:bad-variable every)
+ (cons the-scm-module
+ (map resolve-interface
+ '((test-suite lib) (srfi srfi-1)))))
+
+ ;; For renamed bindings, a custom interface is used so we can't
+ ;; check for equality with `eq?'.
+ (every? (lambda (sym iface)
+ (let ((import
+ (module-import-interface (current-module) sym)))
+ (equal? (module-name import)
+ (module-name iface))))
+ '(s:make-stream s:stream-car s:stream-cdr)
+ (make-list 3 (resolve-interface '(ice-9 streams))))))
+
+ (pass-if "module-reverse-lookup"
+ (let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams)))
+ (syms '(every exception:bad-variable make-stream))
+ (locals '(every exception:bad-variable s:make-stream)))
+ (every? (lambda (var sym)
+ (eq? (module-reverse-lookup (current-module) var)
+ sym))
+ (map module-variable
+ (map resolve-interface mods)
+ syms)
+ locals))))
+
+
+
+;;;
+;;; Observers.
+;;;
+
+(with-test-prefix "observers"
+
+ (pass-if "weak observer invoked"
+ (let* ((m (make-module))
+ (invoked 0))
+ (module-observe-weak m (lambda (mod)
+ (if (eq? mod m)
+ (set! invoked (+ invoked 1)))))
+ (module-define! m 'something 2)
+ (module-define! m 'something-else 1)
+ (= invoked 2)))
+
+ (pass-if "all weak observers invoked"
+ (let* ((m (make-module))
+ (observer-count 500)
+ (observer-ids (let loop ((i observer-count)
+ (ids '()))
+ (if (= i 0)
+ ids
+ (loop (- i 1) (cons (make-module) ids)))))
+ (observers-invoked (make-hash-table observer-count)))
+
+ ;; register weak observers
+ (for-each (lambda (id)
+ (module-observe-weak m id
+ (lambda (m)
+ (hashq-set! observers-invoked
+ id #t))))
+ observer-ids)
+
+ ;; invoke them
+ (module-call-observers m)
+
+ ;; make sure all of them were invoked
+ (->bool (every (lambda (id)
+ (hashq-ref observers-invoked id))
+ observer-ids))))
+
+ (pass-if "imported bindings updated"
+ (let ((m (make-module))
+ (imported (make-module)))
+ ;; Beautify them, notably adding them a public interface.
+ (beautify-user-module! m)
+ (beautify-user-module! imported)
+
+ (module-use! m (module-public-interface imported))
+ (module-define! imported 'imported-binding #t)
+
+ ;; At this point, `imported-binding' is local to IMPORTED.
+ (and (not (module-variable m 'imported-binding))
+ (begin
+ ;; Export `imported-binding' from IMPORTED.
+ (module-export! imported '(imported-binding))
+
+ ;; Make sure it is now visible from M.
+ (module-ref m 'imported-binding))))))
+
+
+
+;;;
+;;; Duplicate bindings handling.
+;;;
+
+(with-test-prefix "duplicate bindings"
+
+ (pass-if "simple duplicate handler"
+ ;; Import the same binding twice.
+ (let* ((m (make-module))
+ (import1 (make-module))
+ (import2 (make-module))
+ (handler-invoked? #f)
+ (handler (lambda (module name int1 val1 int2 val2 var val)
+ (set! handler-invoked? #t)
+ ;; Keep the first binding.
+ (or var (module-local-variable int1 name)))))
+
+ (set-module-duplicates-handlers! m (list handler))
+ (module-define! m 'something 'something)
+ (module-define! import1 'imported 'imported-1)
+ (module-define! import2 'imported 'imported-2)
+ (module-use! m import1)
+ (module-use! m import2)
+ (and handler-invoked?
+ (eq? (module-ref m 'imported) 'imported-1)))))
+
+
+;;;
+;;; Lazy binder.
+;;;
+
+(with-test-prefix "lazy binder"
+
+ (pass-if "not invoked"
+ (let ((m (make-module))
+ (invoked? #f))
+ (module-define! m 'something 2)
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (and (module-ref m 'something)
+ (not invoked?))))
+
+ (pass-if "not invoked (module-add!)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (module-add! m 'something (make-variable 2))
+ (and (module-ref m 'something)
+ (not invoked?))))
+
+ (pass-if "invoked (module-ref)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (false-if-exception (module-ref m 'something))
+ invoked?))
+
+ (pass-if "invoked (module-define!)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (module-define! m 'something 2)
+ (and invoked?
+ (eq? (module-ref m 'something) 2))))
+
+ (pass-if "honored (ref)"
+ (let ((m (make-module))
+ (invoked? #f)
+ (value (cons 'x 'y)))
+ (set-module-binder! m
+ (lambda (mod sym define?)
+ (set! invoked? #t)
+ (cond ((not (eq? m mod))
+ (error "invalid module" mod))
+ (define?
+ (error "DEFINE? shouldn't be set"))
+ (else
+ (make-variable value)))))
+ (and (eq? (module-ref m 'something) value)
+ invoked?))))
+
+
+
+;;;
+;;; Higher-level features.
+;;;
(with-test-prefix "autoload"
+ (pass-if "module-autoload!"
+ (let ((m (make-module)))
+ (module-autoload! m '(ice-9 q) '(make-q))
+ (not (not (module-ref m 'make-q)))))
+
(pass-if "autoloaded"
(catch #t
(lambda ()
- Evolution & optimization of the module system,
Ludovic Courtès <=
- Re: Evolution & optimization of the module system, Kevin Ryde, 2007/02/18
- Re: Evolution & optimization of the module system, Ludovic Courtès, 2007/02/19
- Re: Evolution & optimization of the module system, Kevin Ryde, 2007/02/21
- Re: Evolution & optimization of the module system, Ludovic Courtès, 2007/02/22
- Re: Evolution & optimization of the module system, Kevin Ryde, 2007/02/22
- Re: Evolution & optimization of the module system, Ludovic Courtès, 2007/02/23
- Re: Evolution & optimization of the module system, Kevin Ryde, 2007/02/25
- Re: Evolution & optimization of the module system, Ludovic Courtès, 2007/02/26
- Re: Evolution & optimization of the module system, Kevin Ryde, 2007/02/26
- Re: Evolution & optimization of the module system, Ludovic Courtès, 2007/02/27