mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 02:00:26 +02:00
Code Activity

Changes from arch/CVS synchronization

Browse source
This commit is contained in:
Ludovic Courtès 2007-05-05 20:38:57 +00:00
parent 51a3fdd836
commit 608860a5b3
9 changed files with 709 additions and 230 deletions
Download patch file Download diff file Expand all files Collapse all files

38
ice-9/ChangeLog
View file

@ -1,3 +1,41 @@
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
Implemented lazy duplicate binding handling. Fixed the
`module-observe-weak' API.
* boot-9.scm: Updated the `module-type' documentation under "{Low
Level Modules}".
(module-type)[import-obarray]: New slot.
[duplicates-interface, observer-id]: Removed.
(make-module): Updated accordingly. Use a weak-key hash table for
weak observers, so that observers aren't unregistered when the
observing closure gets GC'd.
(module-duplicates-interface, set-module-duplicates-interface!,
module-observer-id, set-module-observer-id!): Removed.
(module-import-obarray): New.
(module-observe-weak): Accept a new OBSERVER-ID argument allowing
callers control over when the observer will get unregistered.
(module-call-observers): Use `hash-for-each' rather than
`hash-fold'.
(module-local-variable, module-variable): Removed, now implemented
in C.
(module-make-local-var!): Simplified. No need to check for the
value of a same-named imported binding since the newly created
variable is systematically assigned afterwards.
(module-use!): Check whether MODULE and INTERFACE are `eq?'.
(module-use-interfaces!): Simplified. No longer calls
`process-duplicates'.
(beautify-user-module!): Use `module-use!' rather than
`set-module-uses!' when importing THE-SCM-MODULE.
(process-define-module): Added an AUTOLOADS local variable so that
autoloads are handled separately from regular interfaces.
(make-autoload-interface): Updated `module-constructor'
invocation.
(module-autoload!): New.
(make-duplicates-interface, process-duplicates): Removed.
(top-repl): Use `module-autoload!' rather than
`make-autoload-interface'.
2007-02-18 Neil Jerram <neil@ossau.uklinux.net> 2007-02-18 Neil Jerram <neil@ossau.uklinux.net>
* gds-client.scm (connect-to-gds): Break generation of client name * gds-client.scm (connect-to-gds): Break generation of client name

275
ice-9/boot-9.scm
View file

@ -1098,18 +1098,20 @@
;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind ;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
;;; is set, it defaults to 'module. ;;; is set, it defaults to 'module.
;;; ;;;
;;; - duplicates-handlers ;;; - duplicates-handlers: a list of procedures that get called to make a
;;; choice between two duplicate bindings when name clashes occur. See the
;;; `duplicate-handlers' global variable below.
;;; ;;;
;;; - duplicates-interface ;;; - observers: a list of procedures that get called when the module is
;;; modified.
;;; ;;;
;;; - observers ;;; - weak-observers: a weak-key hash table of procedures that get called
;;; ;;; when the module is modified. See `module-observe-weak' for details.
;;; - weak-observers
;;;
;;; - observer-id
;;; ;;;
;;; In addition, the module may (must?) contain a binding for ;;; In addition, the module may (must?) contain a binding for
;;; %module-public-interface... More explanations here... ;;; `%module-public-interface'. This variable should be bound to a module
;;; representing the exported interface of a module. See the
;;; `module-public-interface' and `module-export!' procedures.
;;; ;;;
;;; !!! warning: The interface to lazy binder procedures is going ;;; !!! warning: The interface to lazy binder procedures is going
;;; to be changed in an incompatible way to permit all the basic ;;; to be changed in an incompatible way to permit all the basic
@ -1173,8 +1175,8 @@
(define module-type (define module-type
(make-record-type 'module (make-record-type 'module
'(obarray uses binder eval-closure transformer name kind '(obarray uses binder eval-closure transformer name kind
duplicates-handlers duplicates-interface duplicates-handlers import-obarray
observers weak-observers observer-id) observers weak-observers)
%print-module)) %print-module))
;; make-module &opt size uses binder ;; make-module &opt size uses binder
@ -1190,6 +1192,10 @@
(list-ref args index) (list-ref args index)
default)) default))
(define %default-import-size
;; Typical number of imported bindings actually used by a module.
600)
(if (> (length args) 3) (if (> (length args) 3)
(error "Too many args to make-module." args)) (error "Too many args to make-module." args))
@ -1207,10 +1213,10 @@
"Lazy-binder expected to be a procedure or #f." binder)) "Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-hash-table size) (let ((module (module-constructor (make-hash-table size)
uses binder #f #f #f #f #f #f uses binder #f #f #f #f #f
(make-hash-table %default-import-size)
'() '()
(make-weak-value-hash-table 31) (make-weak-key-hash-table 31))))
0)))
;; We can't pass this as an argument to module-constructor, ;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module ;; because we need it to close over a pointer to the module
@ -1240,17 +1246,13 @@
(record-accessor module-type 'duplicates-handlers)) (record-accessor module-type 'duplicates-handlers))
(define set-module-duplicates-handlers! (define set-module-duplicates-handlers!
(record-modifier module-type '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 module-observers (record-accessor module-type 'observers))
(define set-module-observers! (record-modifier module-type 'observers)) (define set-module-observers! (record-modifier module-type 'observers))
(define module-weak-observers (record-accessor module-type 'weak-observers)) (define module-weak-observers (record-accessor module-type 'weak-observers))
(define module-observer-id (record-accessor module-type 'observer-id))
(define set-module-observer-id! (record-modifier module-type 'observer-id))
(define module? (record-predicate module-type)) (define module? (record-predicate module-type))
(define module-import-obarray (record-accessor module-type 'import-obarray))
(define set-module-eval-closure! (define set-module-eval-closure!
(let ((setter (record-modifier module-type 'eval-closure))) (let ((setter (record-modifier module-type 'eval-closure)))
(lambda (module closure) (lambda (module closure)
@ -1269,11 +1271,19 @@
(set-module-observers! module (cons proc (module-observers module))) (set-module-observers! module (cons proc (module-observers module)))
(cons module proc)) (cons module proc))
(define (module-observe-weak module proc) (define (module-observe-weak module observer-id . proc)
(let ((id (module-observer-id module))) ;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
(hash-set! (module-weak-observers module) id proc) ;; be any Scheme object). PROC is invoked and passed MODULE any time
(set-module-observer-id! module (+ 1 id)) ;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
(cons module id))) ;; (thus, it is never unregistered if OBSERVER-ID is an immediate value,
;; for instance).
;; The two-argument version is kept for backward compatibility: when called
;; with two arguments, the observer gets unregistered when closure PROC
;; gets GC'd (making it impossible to use an anonymous lambda for PROC).
(let ((proc (if (null? proc) observer-id (car proc))))
(hashq-set! (module-weak-observers module) observer-id proc)))
(define (module-unobserve token) (define (module-unobserve token)
(let ((module (car token)) (let ((module (car token))
@ -1311,7 +1321,11 @@
(define (module-call-observers m) (define (module-call-observers m)
(for-each (lambda (proc) (proc m)) (module-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 +1449,8 @@
;;; ;;;
;;; If the symbol is not found at all, return #f. ;;; If the symbol is not found at all, return #f.
;;; ;;;
(define (module-local-variable m v) ;;; (This is now written in C, see `modules.c'.)
; (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))
;;; {Mapping modules x symbols --> bindings} ;;; {Mapping modules x symbols --> bindings}
;;; ;;;
@ -1515,19 +1511,10 @@
(module-modified m) (module-modified m)
b))) b)))
;; No local variable yet, so we need to create a new one. That ;; Create a new local variable.
;; new variable is initialized with the old imported value of V, (let ((local-var (make-undefined-variable)))
;; if there is one. (module-add! m v local-var)
(let ((imported-var (module-variable m v)) local-var)))
(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)))
;; module-ensure-local-variable! module symbol ;; module-ensure-local-variable! module symbol
;; ;;
@ -1696,46 +1683,29 @@
;; Add INTERFACE to the list of interfaces used by MODULE. ;; Add INTERFACE to the list of interfaces used by MODULE.
;; ;;
(define (module-use! module interface) (define (module-use! module interface)
(set-module-uses! module (if (not (eq? module interface))
(cons interface (begin
(filter (lambda (m) ;; Newly used modules must be appended rather than consed, so that
(not (equal? (module-name m) ;; `module-variable' traverses the use list starting from the first
(module-name interface)))) ;; used module.
(module-uses module)))) (set-module-uses! module
(module-modified module)) (append (filter (lambda (m)
(not
(equal? (module-name m)
(module-name interface))))
(module-uses module))
(list interface)))
(module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces ;; MODULE-USE-INTERFACES! module interfaces
;; ;;
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
;; ;;
(define (module-use-interfaces! module interfaces) (define (module-use-interfaces! module interfaces)
(let* ((duplicates-handlers? (or (module-duplicates-handlers module) (set-module-uses! module
(default-duplicate-binding-procedures))) (append (module-uses module) interfaces))
(uses (module-uses module))) (module-modified 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)))
@ -1861,8 +1831,8 @@
(set-module-public-interface! module interface)))) (set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module))) (if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module))) (not (eq? module the-root-module)))
(set-module-uses! module ;; Import the default set of bindings (from the SCM module) in MODULE.
(append (module-uses module) (list the-scm-module))))) (module-use! module the-scm-module)))
;; NOTE: This binding is used in libguile/modules.c. ;; NOTE: This binding is used in libguile/modules.c.
;; ;;
@ -1893,6 +1863,7 @@
(define process-define-module #f) (define process-define-module #f)
(define process-use-modules #f) (define process-use-modules #f)
(define module-export! #f) (define module-export! #f)
(define default-duplicate-binding-procedures #f)
;; This boots the module system. All bindings needed by modules.c ;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now. ;; must have been defined by now.
@ -2027,7 +1998,8 @@
(reversed-interfaces '()) (reversed-interfaces '())
(exports '()) (exports '())
(re-exports '()) (re-exports '())
(replacements '())) (replacements '())
(autoloads '()))
(if (null? kws) (if (null? kws)
(call-with-deferred-observers (call-with-deferred-observers
@ -2035,7 +2007,9 @@
(module-use-interfaces! module (reverse reversed-interfaces)) (module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports) (module-export! module exports)
(module-replace! module replacements) (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) (case (car kws)
((#:use-module #:use-syntax) ((#:use-module #:use-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
@ -2055,31 +2029,35 @@
(cons interface reversed-interfaces) (cons interface reversed-interfaces)
exports exports
re-exports re-exports
replacements))) replacements
autoloads)))
((#:autoload) ((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws))) (or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws)) (unrecognized kws))
(loop (cdddr kws) (loop (cdddr kws)
(cons (make-autoload-interface module reversed-interfaces
(cadr kws)
(caddr kws))
reversed-interfaces)
exports exports
re-exports re-exports
replacements)) replacements
(let ((name (cadr kws))
(bindings (caddr kws)))
(cons* name bindings autoloads))))
((#:no-backtrace) ((#:no-backtrace)
(set-system-module! module #t) (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) ((#:pure)
(purify-module! module) (purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports replacements)) (loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
((#:duplicates) ((#:duplicates)
(if (not (pair? (cdr kws))) (if (not (pair? (cdr kws)))
(unrecognized kws)) (unrecognized kws))
(set-module-duplicates-handlers! (set-module-duplicates-handlers!
module module
(lookup-duplicates-handlers (cadr kws))) (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) ((#:export #:export-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
(unrecognized kws)) (unrecognized kws))
@ -2087,7 +2065,8 @@
reversed-interfaces reversed-interfaces
(append (cadr kws) exports) (append (cadr kws) exports)
re-exports re-exports
replacements)) replacements
autoloads))
((#:re-export #:re-export-syntax) ((#:re-export #:re-export-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
(unrecognized kws)) (unrecognized kws))
@ -2095,7 +2074,8 @@
reversed-interfaces reversed-interfaces
exports exports
(append (cadr kws) re-exports) (append (cadr kws) re-exports)
replacements)) replacements
autoloads))
((#:replace #:replace-syntax) ((#:replace #:replace-syntax)
(or (pair? (cdr kws)) (or (pair? (cdr kws))
(unrecognized kws)) (unrecognized kws))
@ -2103,7 +2083,8 @@
reversed-interfaces reversed-interfaces
exports exports
re-exports re-exports
(append (cadr kws) replacements))) (append (cadr kws) replacements)
autoloads))
(else (else
(unrecognized kws))))) (unrecognized kws)))))
(run-hook module-defined-hook module) (run-hook module-defined-hook module)
@ -2131,8 +2112,26 @@
(if (pair? autoload) (if (pair? autoload)
(set-car! autoload i))) (set-car! autoload i)))
(module-local-variable i sym)))))) (module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
'() (make-weak-value-hash-table 31) 0))) (make-hash-table 0) '() (make-weak-value-hash-table 31))))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
of the symbols listed in @var{bindings} is looked up. @var{args} should be a
list of module-name/binding-list pairs, e.g., as in @code{(module-autoload!
module '(ice-9 q) '(make-q q-length))}."
(let loop ((args args))
(cond ((null? args)
#t)
((null? (cdr args))
(error "invalid name+binding autoload list" args))
(else
(let ((name (car args))
(bindings (cadr args)))
(module-use! module (make-autoload-interface module
name bindings))
(loop (cddr args)))))))
;;; {Compiled module} ;;; {Compiled module}
@ -3133,57 +3132,6 @@
(lookup-duplicates-handlers handler-names)) (lookup-duplicates-handlers handler-names))
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)
(let* ((duplicates-handlers (or (module-duplicates-handlers module)
(default-duplicate-binding-procedures)))
(duplicates-interface (module-duplicates-interface module)))
(module-for-each
(lambda (name var)
(cond ((module-import-interface module name)
=>
(lambda (prev-interface)
(let ((var1 (module-local-variable prev-interface name))
(var2 (module-local-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))
(val (and var
(variable-bound? var)
(variable-ref var))))
(let loop ((duplicates-handlers duplicates-handlers))
(cond ((null? duplicates-handlers))
(((car duplicates-handlers)
module
name
prev-interface
(and (variable-bound? var1)
(variable-ref var1))
interface
(and (variable-bound? var2)
(variable-ref var2))
var
val)
=>
(lambda (var)
(module-add! duplicates-interface name var)))
(else
(loop (cdr duplicates-handlers)))))))))))))
interface)))
;;; {`cond-expand' for SRFI-0 support.} ;;; {`cond-expand' for SRFI-0 support.}
@ -3398,10 +3346,7 @@
'(((ice-9 threads))) '(((ice-9 threads)))
'()))) '())))
;; load debugger on demand ;; load debugger on demand
(module-use! guile-user-module (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
(make-autoload-interface guile-user-module
'(ice-9 debugger) '(debug)))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have

18
libguile/ChangeLog
View file

@ -1,3 +1,21 @@
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
Implemented lazy duplicate binding handling.
* modules.c (scm_export): Renamed to...
(scm_module_export): This. Now public.
(module_variable): Removed.
(default_duplicate_binding_procedures_var): New variable.
(default_duplicate_binding_handlers, resolve_duplicate_binding,
module_imported_variable, scm_module_local_variable,
scm_module_variable): New functions.
(scm_module_import_interface): Rewritten.
(scm_module_reverse_lookup): Exported as a Scheme function.
* modules.h (scm_module_index_duplicate_handlers,
scm_module_index_import_obarray): New macros.
(scm_module_variable, scm_module_local_variable,
scm_module_export): New declarations.
2007-04-17 Ludovic Courtès <ludovic.courtes@laas.fr> 2007-04-17 Ludovic Courtès <ludovic.courtes@laas.fr>
* numbers.c: Commented out trailing `HAVE_COMPLEX_DOUBLE' after * numbers.c: Commented out trailing `HAVE_COMPLEX_DOUBLE' after

305
libguile/modules.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1998,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc. /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public * modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either * License as published by the Free Software Foundation; either
@ -162,12 +162,8 @@ scm_c_use_module (const char *name)
static SCM module_export_x_var; static SCM module_export_x_var;
SCM
/* scm_module_export (SCM module, SCM namelist)
TODO: should export this function? --hwn.
*/
static SCM
scm_export (SCM module, SCM namelist)
{ {
return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var), return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
module, namelist); module, namelist);
@ -203,7 +199,7 @@ scm_c_export (const char *name, ...)
tail = SCM_CDRLOC (*tail); tail = SCM_CDRLOC (*tail);
} }
va_end (ap); va_end (ap);
scm_export (scm_current_module(), names); scm_module_export (scm_current_module (), names);
} }
} }
@ -278,42 +274,220 @@ SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
* release. * release.
*/ */
static SCM module_make_local_var_x_var; /* The `module-make-local-var!' variable. */
static SCM module_make_local_var_x_var = SCM_UNSPECIFIED;
static SCM /* The `default-duplicate-binding-procedures' variable. */
module_variable (SCM module, SCM sym) static SCM default_duplicate_binding_procedures_var = SCM_UNSPECIFIED;
/* Return the list of default duplicate binding handlers (procedures). */
static inline SCM
default_duplicate_binding_handlers (void)
{
SCM get_handlers;
get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
return (scm_call_0 (get_handlers));
}
/* Resolve the import of SYM in MODULE, where SYM is currently provided by
both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
duplicate binding handlers or `#f'. */
static inline SCM
resolve_duplicate_binding (SCM module, SCM sym,
SCM iface1, SCM var1,
SCM iface2, SCM var2)
{
SCM result = SCM_BOOL_F;
if (!scm_is_eq (var1, var2))
{
SCM val1, val2;
SCM handlers, h, handler_args;
val1 = SCM_VARIABLE_REF (var1);
val2 = SCM_VARIABLE_REF (var2);
val1 = (val1 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
val2 = (val2 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
if (scm_is_false (handlers))
handlers = default_duplicate_binding_handlers ();
handler_args = scm_list_n (module, sym,
iface1, val1, iface2, val2,
var1, val1,
SCM_UNDEFINED);
for (h = handlers;
scm_is_pair (h) && scm_is_false (result);
h = SCM_CDR (h))
{
result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
}
}
else
result = var1;
return result;
}
/* Lookup SYM as an imported variable of MODULE. */
static inline SCM
module_imported_variable (SCM module, SCM sym)
{
#define SCM_BOUND_THING_P scm_is_true
register SCM var, imports;
/* Search cached imported bindings. */
imports = SCM_MODULE_IMPORT_OBARRAY (module);
var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (var))
return var;
{
/* Search the use list for yet uncached imported bindings, possibly
resolving duplicates as needed and caching the result in the import
obarray. */
SCM uses;
SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
for (uses = SCM_MODULE_USES (module);
scm_is_pair (uses);
uses = SCM_CDR (uses))
{
SCM iface;
iface = SCM_CAR (uses);
var = scm_module_variable (iface, sym);
if (SCM_BOUND_THING_P (var))
{
if (SCM_BOUND_THING_P (found_var))
{
/* SYM is a duplicate binding (imported more than once) so we
need to resolve it. */
found_var = resolve_duplicate_binding (module, sym,
found_iface, found_var,
iface, var);
if (scm_is_eq (found_var, var))
found_iface = iface;
}
else
/* Keep track of the variable we found and check for other
occurences of SYM in the use list. */
found_var = var, found_iface = iface;
}
}
if (SCM_BOUND_THING_P (found_var))
{
/* Save the lookup result for future reference. */
(void) scm_hashq_set_x (imports, sym, found_var);
return found_var;
}
}
return SCM_BOOL_F;
#undef SCM_BOUND_THING_P
}
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) \ #define SCM_BOUND_THING_P(b) \
(scm_is_true (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 */ /* 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)) if (SCM_BOUND_THING_P (b))
return 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 = module_imported_variable (module, sym);
if (SCM_BOUND_THING_P (b))
return SCM_BOOL_F;
{ {
/* 3. Query the custom binder. */
SCM binder = SCM_MODULE_BINDER (module); SCM binder = SCM_MODULE_BINDER (module);
if (scm_is_true (binder)) if (scm_is_true (binder))
/* 2. Custom binder */
{ {
b = scm_call_3 (binder, module, sym, SCM_BOOL_F); b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b)) if (SCM_BOUND_THING_P (b))
return b; return b;
} }
} }
{
/* 3. Search the use list */ return SCM_BOOL_F;
SCM uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses))
{
b = module_variable (SCM_CAR (uses), sym);
if (SCM_BOUND_THING_P (b))
return b;
uses = SCM_CDR (uses);
}
return SCM_BOOL_F;
}
#undef SCM_BOUND_THING_P #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
{
#define SCM_BOUND_THING_P(b) \
(scm_is_true (b))
register SCM var;
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
/* 1. Check module obarray */
var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (var))
return var;
/* 2. Search among the imported variables. */
var = module_imported_variable (module, sym);
if (SCM_BOUND_THING_P (var))
return var;
{
/* 3. Query the custom binder. */
SCM binder;
binder = SCM_MODULE_BINDER (module);
if (scm_is_true (binder))
{
var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (var))
return var;
}
}
return SCM_BOOL_F;
#undef SCM_BOUND_THING_P
}
#undef FUNC_NAME
scm_t_bits scm_tc16_eval_closure; scm_t_bits scm_tc16_eval_closure;
@ -335,7 +509,7 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
module, sym); module, sym);
} }
else else
return module_variable (module, sym); return scm_module_variable (module, sym);
} }
SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
@ -398,38 +572,44 @@ scm_current_module_transformer ()
SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
(SCM module, SCM sym), (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 FUNC_NAME s_scm_module_import_interface
{ {
#define SCM_BOUND_THING_P(b) (scm_is_true (b)) SCM var, result = SCM_BOOL_F;
SCM uses;
SCM_VALIDATE_MODULE (SCM_ARG1, module); SCM_VALIDATE_MODULE (1, module);
/* Search the use list */ SCM_VALIDATE_SYMBOL (2, sym);
uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses)) var = scm_module_variable (module, sym);
if (scm_is_true (var))
{ {
SCM _interface = SCM_CAR (uses); /* Look for the module that provides VAR. */
/* 1. Check module obarray */ SCM local_var;
SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b)) local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
return _interface; SCM_UNDEFINED);
{ if (scm_is_eq (local_var, var))
SCM binder = SCM_MODULE_BINDER (_interface); result = module;
if (scm_is_true (binder)) else
/* 2. Custom binder */ {
{ /* Look for VAR among the used modules. */
b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F); SCM uses, imported_var;
if (SCM_BOUND_THING_P (b))
return _interface; for (uses = SCM_MODULE_USES (module);
} scm_is_pair (uses) && scm_is_false (result);
} uses = SCM_CDR (uses))
/* 3. Search use list recursively. */ {
_interface = scm_module_import_interface (_interface, sym); imported_var = scm_module_variable (SCM_CAR (uses), sym);
if (scm_is_true (_interface)) if (scm_is_eq (imported_var, var))
return _interface; result = SCM_CAR (uses);
uses = SCM_CDR (uses); }
}
} }
return SCM_BOOL_F;
return result;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -560,9 +740,13 @@ scm_define (SCM sym, SCM value)
return var; return var;
} }
SCM SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
scm_module_reverse_lookup (SCM module, SCM variable) (SCM module, SCM variable),
#define FUNC_NAME "module-reverse-lookup" "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; SCM obarray;
long i, n; long i, n;
@ -594,8 +778,7 @@ scm_module_reverse_lookup (SCM module, SCM variable)
} }
} }
/* Try the `uses' list. /* Try the `uses' list. */
*/
{ {
SCM uses = SCM_MODULE_USES (module); SCM uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses)) while (scm_is_pair (uses))
@ -669,6 +852,8 @@ scm_post_boot_init_modules ()
process_use_modules_var = PERM (scm_c_lookup ("process-use-modules")); process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
module_export_x_var = PERM (scm_c_lookup ("module-export!")); module_export_x_var = PERM (scm_c_lookup ("module-export!"));
the_root_module_var = PERM (scm_c_lookup ("the-root-module")); the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
default_duplicate_binding_procedures_var =
PERM (scm_c_lookup ("default-duplicate-binding-procedures"));
scm_module_system_booted_p = 1; scm_module_system_booted_p = 1;
} }

11
libguile/modules.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_MODULES_H #ifndef SCM_MODULES_H
#define SCM_MODULES_H #define SCM_MODULES_H
/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc. /* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public * modify it under the terms of the GNU Lesser General Public
@ -45,6 +45,8 @@ SCM_API scm_t_bits scm_module_tag;
#define scm_module_index_binder 2 #define scm_module_index_binder 2
#define scm_module_index_eval_closure 3 #define scm_module_index_eval_closure 3
#define scm_module_index_transformer 4 #define scm_module_index_transformer 4
#define scm_module_index_duplicate_handlers 7
#define scm_module_index_import_obarray 8
#define SCM_MODULE_OBARRAY(module) \ #define SCM_MODULE_OBARRAY(module) \
SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray]) SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray])
@ -56,6 +58,10 @@ SCM_API scm_t_bits scm_module_tag;
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure]) SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure])
#define SCM_MODULE_TRANSFORMER(module) \ #define SCM_MODULE_TRANSFORMER(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer]) SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer])
#define SCM_MODULE_DUPLICATE_HANDLERS(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_duplicate_handlers])
#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; SCM_API scm_t_bits scm_tc16_eval_closure;
@ -64,6 +70,8 @@ SCM_API scm_t_bits scm_tc16_eval_closure;
SCM_API SCM scm_current_module (void); 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_interaction_environment (void);
SCM_API SCM scm_set_current_module (SCM module); SCM_API SCM scm_set_current_module (SCM module);
@ -80,6 +88,7 @@ SCM_API SCM scm_c_module_lookup (SCM module, const char *name);
SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val); 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_lookup (SCM module, SCM symbol);
SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val); 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_module_reverse_lookup (SCM module, SCM variable);
SCM_API SCM scm_c_resolve_module (const char *name); SCM_API SCM scm_c_resolve_module (const char *name);

5
oop/ChangeLog
View file

@ -1,3 +1,8 @@
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
* goops/internal.scm: Use the public module API rather than hack
with `%module-public-interface', `nested-ref', et al.
2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se> 2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* accessors.scm, simple.scm: New files. * accessors.scm, simple.scm: New files.

9
oop/goops/internal.scm
View file

@ -21,5 +21,10 @@
(define-module (oop goops internal) (define-module (oop goops internal)
:use-module (oop goops)) :use-module (oop goops))
(set-module-uses! %module-public-interface ;; Export all the bindings that are internal to `(oop goops)'.
(list (nested-ref the-root-module '(app modules 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))))

7
test-suite/ChangeLog
View file

@ -1,3 +1,10 @@
2007-05-05 Ludovic Courtès <ludo@chbouib.org>
* tests/modules.test: Use `define-module'. Use `(srfi srfi-1)'.
(foundations, observers, duplicate bindings, lazy binder): New
test prefixes.
(autoload)[module-autoload!]: New test.
2007-03-08 Kevin Ryde <user42@zip.com.au> 2007-03-08 Kevin Ryde <user42@zip.com.au>
* tests/structs.test (make-struct): Exercise the error check on tail * tests/structs.test (make-struct): Exercise the error check on tail

271
test-suite/tests/modules.test
View file

@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -16,10 +16,277 @@
;;;; License along with this library; if not, write to the Free Software ;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; 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"
;; With the two-argument `module-observe-weak' available in previous
;; versions, the observer would get unregistered as soon as the observing
;; closure gets GC'd, making it impossible to use an anonymous lambda as
;; the observing procedure.
(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)
(gc)
;; 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)
(set-module-name! import1 'imported-module-1)
(set-module-name! import2 'imported-module-2)
(module-define! import1 'imported 'imported-1)
(module-define! import2 'imported 'imported-2)
(module-use! m import1)
(module-use! m import2)
(and (eq? (module-ref m 'imported) 'imported-1)
handler-invoked?))))
;;;
;;; 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" (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" (pass-if "autoloaded"
(catch #t (catch #t
(lambda () (lambda ()