mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 02:00:26 +02:00
Changes from arch/CVS synchronization
This commit is contained in:
Ludovic Courtès
parent
51a3fdd836
commit
608860a5b3
9 changed files with 709 additions and 230 deletions
|
|
@ -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>
|
||||
|
||||
* gds-client.scm (connect-to-gds): Break generation of client name
|
||||
|
|
|
|||
267
ice-9/boot-9.scm
267
ice-9/boot-9.scm
|
|
@ -1098,18 +1098,20 @@
|
|||
;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
|
||||
;;; 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
|
||||
;;;
|
||||
;;; - observer-id
|
||||
;;; - weak-observers: a weak-key hash table of procedures that get called
|
||||
;;; when the module is modified. See `module-observe-weak' for details.
|
||||
;;;
|
||||
;;; 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
|
||||
;;; to be changed in an incompatible way to permit all the basic
|
||||
|
|
@ -1173,8 +1175,8 @@
|
|||
(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 import-obarray
|
||||
observers weak-observers)
|
||||
%print-module))
|
||||
|
||||
;; make-module &opt size uses binder
|
||||
|
|
@ -1190,6 +1192,10 @@
|
|||
(list-ref args index)
|
||||
default))
|
||||
|
||||
(define %default-import-size
|
||||
;; Typical number of imported bindings actually used by a module.
|
||||
600)
|
||||
|
||||
(if (> (length args) 3)
|
||||
(error "Too many args to make-module." args))
|
||||
|
||||
|
|
@ -1207,10 +1213,10 @@
|
|||
"Lazy-binder expected to be a procedure or #f." binder))
|
||||
|
||||
(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)
|
||||
0)))
|
||||
(make-weak-key-hash-table 31))))
|
||||
|
||||
;; We can't pass this as an argument to module-constructor,
|
||||
;; because we need it to close over a pointer to the module
|
||||
|
|
@ -1240,17 +1246,13 @@
|
|||
(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))
|
||||
(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-import-obarray (record-accessor module-type 'import-obarray))
|
||||
|
||||
(define set-module-eval-closure!
|
||||
(let ((setter (record-modifier module-type 'eval-closure)))
|
||||
(lambda (module closure)
|
||||
|
|
@ -1269,11 +1271,19 @@
|
|||
(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)
|
||||
;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
|
||||
;; be any Scheme object). PROC is invoked and passed MODULE any time
|
||||
;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
|
||||
;; (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)
|
||||
(let ((module (car token))
|
||||
|
|
@ -1311,7 +1321,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 +1449,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,18 +1511,9 @@
|
|||
(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)))
|
||||
;; 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 +1683,29 @@
|
|||
;; Add INTERFACE to the list of interfaces used by MODULE.
|
||||
;;
|
||||
(define (module-use! module interface)
|
||||
(if (not (eq? module interface))
|
||||
(begin
|
||||
;; Newly used modules must be appended rather than consed, so that
|
||||
;; `module-variable' traverses the use list starting from the first
|
||||
;; used module.
|
||||
(set-module-uses! module
|
||||
(cons interface
|
||||
(filter (lambda (m)
|
||||
(not (equal? (module-name m)
|
||||
(append (filter (lambda (m)
|
||||
(not
|
||||
(equal? (module-name m)
|
||||
(module-name interface))))
|
||||
(module-uses module))))
|
||||
(module-modified module))
|
||||
(module-uses module))
|
||||
(list 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)))
|
||||
(append (module-uses module) interfaces))
|
||||
(module-modified module))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1861,8 +1831,8 @@
|
|||
(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.
|
||||
(module-use! module the-scm-module)))
|
||||
|
||||
;; NOTE: This binding is used in libguile/modules.c.
|
||||
;;
|
||||
|
|
@ -1893,6 +1863,7 @@
|
|||
(define process-define-module #f)
|
||||
(define process-use-modules #f)
|
||||
(define module-export! #f)
|
||||
(define default-duplicate-binding-procedures #f)
|
||||
|
||||
;; This boots the module system. All bindings needed by modules.c
|
||||
;; must have been defined by now.
|
||||
|
|
@ -2027,7 +1998,8 @@
|
|||
(reversed-interfaces '())
|
||||
(exports '())
|
||||
(re-exports '())
|
||||
(replacements '()))
|
||||
(replacements '())
|
||||
(autoloads '()))
|
||||
|
||||
(if (null? kws)
|
||||
(call-with-deferred-observers
|
||||
|
|
@ -2035,7 +2007,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 +2029,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 +2065,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 +2074,8 @@
|
|||
reversed-interfaces
|
||||
exports
|
||||
(append (cadr kws) re-exports)
|
||||
replacements))
|
||||
replacements
|
||||
autoloads))
|
||||
((#:replace #:replace-syntax)
|
||||
(or (pair? (cdr kws))
|
||||
(unrecognized kws))
|
||||
|
|
@ -2103,7 +2083,8 @@
|
|||
reversed-interfaces
|
||||
exports
|
||||
re-exports
|
||||
(append (cadr kws) replacements)))
|
||||
(append (cadr kws) replacements)
|
||||
autoloads))
|
||||
(else
|
||||
(unrecognized kws)))))
|
||||
(run-hook module-defined-hook module)
|
||||
|
|
@ -2131,8 +2112,26 @@
|
|||
(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)))
|
||||
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
|
||||
(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}
|
||||
|
||||
|
|
@ -3133,57 +3132,6 @@
|
|||
(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)
|
||||
(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.}
|
||||
|
|
@ -3398,10 +3346,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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
* numbers.c: Commented out trailing `HAVE_COMPLEX_DOUBLE' after
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* 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
|
||||
* modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -162,12 +162,8 @@ scm_c_use_module (const char *name)
|
|||
|
||||
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 @@ scm_c_export (const char *name, ...)
|
|||
tail = SCM_CDRLOC (*tail);
|
||||
}
|
||||
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.
|
||||
*/
|
||||
|
||||
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
|
||||
module_variable (SCM module, SCM sym)
|
||||
/* The `default-duplicate-binding-procedures' variable. */
|
||||
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) \
|
||||
(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 = 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);
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
{
|
||||
/* 3. Search the use list */
|
||||
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 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;
|
||||
|
||||
|
|
@ -335,7 +509,7 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
|
|||
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 +572,44 @@ scm_current_module_transformer ()
|
|||
|
||||
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 var, result = SCM_BOOL_F;
|
||||
|
||||
SCM_VALIDATE_MODULE (1, module);
|
||||
SCM_VALIDATE_SYMBOL (2, sym);
|
||||
|
||||
var = scm_module_variable (module, sym);
|
||||
if (scm_is_true (var))
|
||||
{
|
||||
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;
|
||||
/* Look for the module that provides VAR. */
|
||||
SCM local_var;
|
||||
|
||||
local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
|
||||
SCM_UNDEFINED);
|
||||
if (scm_is_eq (local_var, var))
|
||||
result = module;
|
||||
else
|
||||
{
|
||||
SCM binder = SCM_MODULE_BINDER (_interface);
|
||||
if (scm_is_true (binder))
|
||||
/* 2. Custom binder */
|
||||
/* Look for VAR among the used modules. */
|
||||
SCM uses, imported_var;
|
||||
|
||||
for (uses = SCM_MODULE_USES (module);
|
||||
scm_is_pair (uses) && scm_is_false (result);
|
||||
uses = SCM_CDR (uses))
|
||||
{
|
||||
b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
|
||||
if (SCM_BOUND_THING_P (b))
|
||||
return _interface;
|
||||
imported_var = scm_module_variable (SCM_CAR (uses), sym);
|
||||
if (scm_is_eq (imported_var, var))
|
||||
result = SCM_CAR (uses);
|
||||
}
|
||||
}
|
||||
/* 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;
|
||||
|
||||
return result;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -560,9 +740,13 @@ scm_define (SCM sym, SCM value)
|
|||
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;
|
||||
|
|
@ -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);
|
||||
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"));
|
||||
module_export_x_var = PERM (scm_c_lookup ("module-export!"));
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef 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
|
||||
* 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_eval_closure 3
|
||||
#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) \
|
||||
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])
|
||||
#define SCM_MODULE_TRANSFORMER(module) \
|
||||
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;
|
||||
|
||||
|
|
@ -64,6 +70,8 @@ SCM_API scm_t_bits scm_tc16_eval_closure;
|
|||
|
||||
|
||||
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 +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_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);
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
* accessors.scm, simple.scm: New files.
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
* tests/structs.test (make-struct): Exercise the error check on tail
|
||||
|
|
|
|||
|
|
@ -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,277 @@
|
|||
;;;; 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"
|
||||
;; 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"
|
||||
|
||||
(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 ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue