mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-04 22:40:25 +02:00
Merge branch 'wip-module-namespaces'
This commit is contained in:
commit
4d67cd4073
11 changed files with 219 additions and 123 deletions
|
@ -42,9 +42,20 @@ int scm_module_system_booted_p = 0;
|
|||
|
||||
scm_t_bits scm_module_tag;
|
||||
|
||||
/* The current module, a fluid. */
|
||||
static SCM the_module;
|
||||
|
||||
/* Most of the module system is implemented in Scheme. These bindings from
|
||||
boot-9 are needed to provide the Scheme interface. */
|
||||
static SCM the_root_module_var;
|
||||
static SCM module_make_local_var_x_var;
|
||||
static SCM process_define_module_var;
|
||||
static SCM process_use_modules_var;
|
||||
static SCM resolve_module_var;
|
||||
static SCM module_public_interface_var;
|
||||
static SCM module_export_x_var;
|
||||
static SCM default_duplicate_binding_procedures_var;
|
||||
|
||||
|
||||
static SCM unbound_variable (const char *func, SCM sym)
|
||||
{
|
||||
|
@ -149,10 +160,6 @@ convert_module_name (const char *name)
|
|||
return list;
|
||||
}
|
||||
|
||||
static SCM process_define_module_var;
|
||||
static SCM process_use_modules_var;
|
||||
static SCM resolve_module_var;
|
||||
|
||||
SCM
|
||||
scm_c_resolve_module (const char *name)
|
||||
{
|
||||
|
@ -183,8 +190,6 @@ scm_c_use_module (const char *name)
|
|||
scm_list_1 (scm_list_1 (convert_module_name (name))));
|
||||
}
|
||||
|
||||
static SCM module_export_x_var;
|
||||
|
||||
SCM
|
||||
scm_module_export (SCM module, SCM namelist)
|
||||
{
|
||||
|
@ -267,12 +272,6 @@ scm_lookup_closure_module (SCM proc)
|
|||
* release.
|
||||
*/
|
||||
|
||||
/* The `module-make-local-var!' variable. */
|
||||
static SCM module_make_local_var_x_var = SCM_UNSPECIFIED;
|
||||
|
||||
/* 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)
|
||||
|
@ -638,24 +637,11 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_SYMBOL (sym_sys_module_public_interface, "%module-public-interface");
|
||||
|
||||
SCM_DEFINE (scm_module_public_interface, "module-public-interface", 1, 0, 0,
|
||||
(SCM module),
|
||||
"Return the public interface of @var{module}.\n\n"
|
||||
"If @var{module} has no public interface, @code{#f} is returned.")
|
||||
#define FUNC_NAME s_scm_module_public_interface
|
||||
SCM
|
||||
scm_module_public_interface (SCM module)
|
||||
{
|
||||
SCM var;
|
||||
|
||||
SCM_VALIDATE_MODULE (1, module);
|
||||
var = scm_module_local_variable (module, sym_sys_module_public_interface);
|
||||
if (scm_is_true (var))
|
||||
return SCM_VARIABLE_REF (var);
|
||||
else
|
||||
return SCM_BOOL_F;
|
||||
return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var), module);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* scm_sym2var
|
||||
*
|
||||
|
@ -899,6 +885,7 @@ scm_post_boot_init_modules ()
|
|||
the_root_module_var = scm_c_lookup ("the-root-module");
|
||||
default_duplicate_binding_procedures_var =
|
||||
scm_c_lookup ("default-duplicate-binding-procedures");
|
||||
module_public_interface_var = scm_c_lookup ("module-public-interface");
|
||||
|
||||
scm_module_system_booted_p = 1;
|
||||
}
|
||||
|
|
|
@ -1551,6 +1551,7 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
;; NOTE: The getter `module-eval-closure' is used in libguile/modules.c.
|
||||
;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
|
||||
;; NOTE: The getter `module-name' is defined later, due to boot reasons.
|
||||
;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
|
||||
;;
|
||||
(define-record-type module
|
||||
(lambda (obj port) (%print-module obj port))
|
||||
|
@ -1565,7 +1566,10 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(import-obarray #:no-setter)
|
||||
observers
|
||||
(weak-observers #:no-setter)
|
||||
version)))
|
||||
version
|
||||
submodules
|
||||
submodule-binder
|
||||
public-interface)))
|
||||
|
||||
|
||||
;; make-module &opt size uses binder
|
||||
|
@ -1606,7 +1610,8 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
#f #f #f
|
||||
(make-hash-table %default-import-size)
|
||||
'()
|
||||
(make-weak-key-hash-table 31) #f)))
|
||||
(make-weak-key-hash-table 31) #f
|
||||
(make-hash-table 7) #f #f)))
|
||||
|
||||
;; We can't pass this as an argument to module-constructor,
|
||||
;; because we need it to close over a pointer to the module
|
||||
|
@ -1916,6 +1921,20 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(define (module-map proc module)
|
||||
(hash-map->list proc (module-obarray module)))
|
||||
|
||||
;; Submodules
|
||||
;;
|
||||
;; Modules exist in a separate namespace from values, because you generally do
|
||||
;; not want the name of a submodule, which you might not even use, to collide
|
||||
;; with local variables that happen to be named the same as the submodule.
|
||||
;;
|
||||
(define (module-ref-submodule module name)
|
||||
(or (hashq-ref (module-submodules module) name)
|
||||
(and (module-submodule-binder module)
|
||||
((module-submodule-binder module) module name))))
|
||||
|
||||
(define (module-define-submodule! module name submodule)
|
||||
(hashq-set! (module-submodules module) name submodule))
|
||||
|
||||
|
||||
|
||||
;;; {Low Level Bootstrapping}
|
||||
|
@ -2070,15 +2089,15 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
;;; {Recursive Namespaces}
|
||||
;;;
|
||||
;;; A hierarchical namespace emerges if we consider some module to be
|
||||
;;; root, and variables bound to modules as nested namespaces.
|
||||
;;; root, and submodules of that module to be nested namespaces.
|
||||
;;;
|
||||
;;; The routines in this file manage variable names in hierarchical namespace.
|
||||
;;; The routines here manage variable names in hierarchical namespace.
|
||||
;;; Each variable name is a list of elements, looked up in successively nested
|
||||
;;; modules.
|
||||
;;;
|
||||
;;; (nested-ref some-root-module '(foo bar baz))
|
||||
;;; => <value of a variable named baz in the module bound to bar in
|
||||
;;; the module bound to foo in some-root-module>
|
||||
;;; => <value of a variable named baz in the submodule bar of
|
||||
;;; the submodule foo of some-root-module>
|
||||
;;;
|
||||
;;;
|
||||
;;; There are:
|
||||
|
@ -2091,50 +2110,104 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
;;; nested-define! a-root name val
|
||||
;;; nested-remove! a-root name
|
||||
;;;
|
||||
;;; These functions manipulate values in namespaces. For referencing the
|
||||
;;; namespaces themselves, use the following:
|
||||
;;;
|
||||
;;; (current-module) is a natural choice for a-root so for convenience there are
|
||||
;;; nested-ref-module a-root name
|
||||
;;; nested-define-module! a-root name mod
|
||||
;;;
|
||||
;;; (current-module) is a natural choice for a root so for convenience there are
|
||||
;;; also:
|
||||
;;;
|
||||
;;; local-ref name == nested-ref (current-module) name
|
||||
;;; local-set! name val == nested-set! (current-module) name val
|
||||
;;; local-define name val == nested-define! (current-module) name val
|
||||
;;; local-remove name == nested-remove! (current-module) name
|
||||
;;; local-ref name == nested-ref (current-module) name
|
||||
;;; local-set! name val == nested-set! (current-module) name val
|
||||
;;; local-define name val == nested-define! (current-module) name val
|
||||
;;; local-remove name == nested-remove! (current-module) name
|
||||
;;; local-ref-module name == nested-ref-module (current-module) name
|
||||
;;; local-define-module! name m == nested-define-module! (current-module) name m
|
||||
;;;
|
||||
|
||||
|
||||
(define (nested-ref root names)
|
||||
(let loop ((cur root)
|
||||
(elts names))
|
||||
(cond
|
||||
((null? elts) cur)
|
||||
((not (module? cur)) #f)
|
||||
(else (loop (module-ref cur (car elts) #f) (cdr elts))))))
|
||||
(if (null? names)
|
||||
root
|
||||
(let loop ((cur root)
|
||||
(head (car names))
|
||||
(tail (cdr names)))
|
||||
(if (null? tail)
|
||||
(module-ref cur head #f)
|
||||
(let ((cur (module-ref-submodule cur head)))
|
||||
(and cur
|
||||
(loop cur (car tail) (cdr tail))))))))
|
||||
|
||||
(define (nested-set! root names val)
|
||||
(let loop ((cur root)
|
||||
(elts names))
|
||||
(if (null? (cdr elts))
|
||||
(module-set! cur (car elts) val)
|
||||
(loop (module-ref cur (car elts)) (cdr elts)))))
|
||||
(head (car names))
|
||||
(tail (cdr names)))
|
||||
(if (null? tail)
|
||||
(module-set! cur head val)
|
||||
(let ((cur (module-ref-submodule cur head)))
|
||||
(if (not cur)
|
||||
(error "failed to resolve module" names)
|
||||
(loop cur (car tail) (cdr tail)))))))
|
||||
|
||||
(define (nested-define! root names val)
|
||||
(let loop ((cur root)
|
||||
(elts names))
|
||||
(if (null? (cdr elts))
|
||||
(module-define! cur (car elts) val)
|
||||
(loop (module-ref cur (car elts)) (cdr elts)))))
|
||||
(head (car names))
|
||||
(tail (cdr names)))
|
||||
(if (null? tail)
|
||||
(module-define! cur head val)
|
||||
(let ((cur (module-ref-submodule cur head)))
|
||||
(if (not cur)
|
||||
(error "failed to resolve module" names)
|
||||
(loop cur (car tail) (cdr tail)))))))
|
||||
|
||||
(define (nested-remove! root names)
|
||||
(let loop ((cur root)
|
||||
(elts names))
|
||||
(if (null? (cdr elts))
|
||||
(module-remove! cur (car elts))
|
||||
(loop (module-ref cur (car elts)) (cdr elts)))))
|
||||
(head (car names))
|
||||
(tail (cdr names)))
|
||||
(if (null? tail)
|
||||
(module-remove! cur head)
|
||||
(let ((cur (module-ref-submodule cur head)))
|
||||
(if (not cur)
|
||||
(error "failed to resolve module" names)
|
||||
(loop cur (car tail) (cdr tail)))))))
|
||||
|
||||
|
||||
(define (nested-ref-module root names)
|
||||
(let loop ((cur root)
|
||||
(names names))
|
||||
(if (null? names)
|
||||
cur
|
||||
(let ((cur (module-ref-submodule cur (car names))))
|
||||
(and cur
|
||||
(loop cur (cdr names)))))))
|
||||
|
||||
(define (nested-define-module! root names module)
|
||||
(if (null? names)
|
||||
(error "can't redefine root module" root module)
|
||||
(let loop ((cur root)
|
||||
(head (car names))
|
||||
(tail (cdr names)))
|
||||
(if (null? tail)
|
||||
(module-define-submodule! cur head module)
|
||||
(let ((cur (or (module-ref-submodule cur head)
|
||||
(let ((m (make-module 31)))
|
||||
(set-module-kind! m 'directory)
|
||||
(set-module-name! m (append (module-name cur)
|
||||
(list head)))
|
||||
(module-define-submodule! cur head m)
|
||||
m))))
|
||||
(loop cur (car tail) (cdr tail)))))))
|
||||
|
||||
|
||||
(define (local-ref names) (nested-ref (current-module) names))
|
||||
(define (local-set! names val) (nested-set! (current-module) names val))
|
||||
(define (local-define names val) (nested-define! (current-module) names val))
|
||||
(define (local-remove names) (nested-remove! (current-module) names))
|
||||
(define (local-ref-module names) (nested-ref-module (current-module) names))
|
||||
(define (local-define-module names mod) (nested-define-module! (current-module) names mod))
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -2147,9 +2220,6 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
;;; better thought of as a root.
|
||||
;;;
|
||||
|
||||
;; module-public-interface is defined in C.
|
||||
(define (set-module-public-interface! m i)
|
||||
(module-define! m '%module-public-interface i))
|
||||
(define (set-system-module! m s)
|
||||
(set-procedure-property! (module-eval-closure m) 'system-module s))
|
||||
(define the-root-module (make-root-module))
|
||||
|
@ -2199,24 +2269,16 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
;; `resolve-module'. This is important as `psyntax' stores module
|
||||
;; names and relies on being able to `resolve-module' them.
|
||||
(set-module-name! mod name)
|
||||
(nested-define! (resolve-module '() #f) name mod)
|
||||
(nested-define-module! (resolve-module '() #f) name mod)
|
||||
(accessor mod))))))
|
||||
|
||||
(define (make-modules-in module name)
|
||||
(if (null? name)
|
||||
module
|
||||
(make-modules-in
|
||||
(let* ((var (module-local-variable module (car name)))
|
||||
(val (and var (variable-bound? var) (variable-ref var))))
|
||||
(if (module? val)
|
||||
val
|
||||
(let ((m (make-module 31)))
|
||||
(set-module-kind! m 'directory)
|
||||
(set-module-name! m (append (module-name module)
|
||||
(list (car name))))
|
||||
(module-define! module (car name) m)
|
||||
m)))
|
||||
(cdr name))))
|
||||
(or (nested-ref-module module name)
|
||||
(let ((m (make-module 31)))
|
||||
(set-module-kind! m 'directory)
|
||||
(set-module-name! m (append (module-name module) name))
|
||||
(nested-define-module! module name m)
|
||||
m)))
|
||||
|
||||
(define (beautify-user-module! module)
|
||||
(let ((interface (module-public-interface module)))
|
||||
|
@ -2340,15 +2402,15 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(let ((root (make-module)))
|
||||
(set-module-name! root '())
|
||||
;; Define the-root-module as '(guile).
|
||||
(module-define! root 'guile the-root-module)
|
||||
(module-define-submodule! root 'guile the-root-module)
|
||||
|
||||
(lambda (name . args) ;; #:optional (autoload #t) (version #f)
|
||||
(let* ((already (nested-ref root name))
|
||||
(let* ((already (nested-ref-module root name))
|
||||
(numargs (length args))
|
||||
(autoload (or (= numargs 0) (car args)))
|
||||
(version (and (> numargs 1) (cadr args))))
|
||||
(cond
|
||||
((and already (module? already)
|
||||
((and already
|
||||
(or (not autoload) (module-public-interface already)))
|
||||
;; A hit, a palpable hit.
|
||||
(if (and version
|
||||
|
@ -2360,10 +2422,10 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(try-load-module name version)
|
||||
(resolve-module name #f))
|
||||
(else
|
||||
;; A module is not bound (but maybe something else is),
|
||||
;; we're not autoloading -- here's the weird semantics,
|
||||
;; we create an empty module.
|
||||
(make-modules-in root name)))))))
|
||||
;; No module found (or if one was, it had no public interface), and
|
||||
;; we're not autoloading. Here's the weird semantics: we ensure
|
||||
;; there's an empty module.
|
||||
(or already (make-modules-in root name))))))))
|
||||
|
||||
|
||||
(define (try-load-module name version)
|
||||
|
@ -2620,7 +2682,8 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(set-car! autoload i)))
|
||||
(module-local-variable i sym))))))
|
||||
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
|
||||
(make-hash-table 0) '() (make-weak-value-hash-table 31) #f)))
|
||||
(make-hash-table 0) '() (make-weak-value-hash-table 31) #f
|
||||
(make-hash-table 0) #f #f)))
|
||||
|
||||
(define (module-autoload! module . args)
|
||||
"Have @var{module} automatically load the module named @var{name} when one
|
||||
|
|
|
@ -38,9 +38,10 @@
|
|||
$tanh
|
||||
closure?
|
||||
%nil
|
||||
@bind
|
||||
%app
|
||||
app))
|
||||
@bind)
|
||||
|
||||
#:replace (module-ref-submodule module-define-submodule!))
|
||||
|
||||
|
||||
;;;; Deprecated definitions.
|
||||
|
||||
|
@ -299,10 +300,53 @@
|
|||
(lambda ()
|
||||
(set! id old-v) ...)))))))))
|
||||
|
||||
;; Define (%app modules)
|
||||
(define %app (make-module 31))
|
||||
(set-module-name! %app '(%app))
|
||||
(nested-define! %app '(modules) (resolve-module '() #f))
|
||||
(define (module-ref-submodule module name)
|
||||
(or (hashq-ref (module-submodules module) name)
|
||||
(and (module-submodule-binder module)
|
||||
((module-submodule-binder module) module name))
|
||||
(let ((var (module-local-variable module name)))
|
||||
(and (variable-bound? var)
|
||||
(module? (variable-ref var))
|
||||
(begin
|
||||
(warn "module" module "not in submodules table")
|
||||
(variable-ref var))))))
|
||||
|
||||
;; app aliases %app
|
||||
(define app %app)
|
||||
(define (module-define-submodule! module name submodule)
|
||||
(let ((var (module-local-variable module name)))
|
||||
(if (and var (variable-bound? var) (not (module? (variable-ref var))))
|
||||
(warn "defining module" module ": not overriding local definition" var)
|
||||
(module-define! module name submodule)))
|
||||
(hashq-set! (module-submodules module) name submodule))
|
||||
|
||||
;; Define (%app) and (%app modules), and have (app) alias (%app). This
|
||||
;; side-effects the-root-module, both to the submodules table and (through
|
||||
;; module-define-submodule! above) the obarray.
|
||||
;;
|
||||
(let ((%app (make-module 31)))
|
||||
(set-module-name! %app '(%app))
|
||||
(module-define-submodule! the-root-module '%app %app)
|
||||
(module-define-submodule! the-root-module 'app %app)
|
||||
(module-define-submodule! %app 'modules (resolve-module '() #f)))
|
||||
|
||||
;; Allow code that poked %module-public-interface to keep on working.
|
||||
;;
|
||||
(set! module-public-interface
|
||||
(let ((getter module-public-interface))
|
||||
(lambda (mod)
|
||||
(or (getter mod)
|
||||
(cond
|
||||
((and=> (module-local-variable mod '%module-public-interface)
|
||||
variable-ref)
|
||||
=> (lambda (iface)
|
||||
(issue-deprecation-warning
|
||||
"Setting a module's public interface via munging %module-public-interface is
|
||||
deprecated. Use set-module-public-interface! instead.")
|
||||
(set-module-public-interface! mod iface)
|
||||
iface))
|
||||
(else #f))))))
|
||||
|
||||
(set! set-module-public-interface!
|
||||
(let ((setter set-module-public-interface!))
|
||||
(lambda (mod iface)
|
||||
(setter mod iface)
|
||||
(module-define! mod '%module-public-interface iface))))
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;;; ls.scm --- functions for browsing modules
|
||||
;;;;
|
||||
;;;; Copyright (C) 1995, 1996, 1997, 1999, 2001, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1995, 1996, 1997, 1999, 2001, 2006, 2010 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
|
||||
|
@ -54,21 +54,19 @@
|
|||
;;; Analogous to `ls', but with local definitions only.
|
||||
|
||||
(define (local-definitions-in root names)
|
||||
(let ((m (nested-ref root names))
|
||||
(answer '()))
|
||||
(if (not (module? m))
|
||||
(set! answer m)
|
||||
(module-for-each (lambda (k v) (set! answer (cons k answer))) m))
|
||||
answer))
|
||||
(let ((m (nested-ref-module root names)))
|
||||
(if m
|
||||
(module-map (lambda (k v) k) m)
|
||||
(nested-ref root names))))
|
||||
|
||||
(define (definitions-in root names)
|
||||
(let ((m (nested-ref root names)))
|
||||
(if (not (module? m))
|
||||
m
|
||||
(let ((m (nested-ref-module root names)))
|
||||
(if m
|
||||
(reduce union
|
||||
(cons (local-definitions-in m '())
|
||||
(cons (local-definitions-in m '())
|
||||
(map (lambda (m2) (definitions-in m2 '()))
|
||||
(module-uses m)))))))
|
||||
(module-uses m))))
|
||||
(nested-ref root names))))
|
||||
|
||||
(define (ls . various-refs)
|
||||
(if (pair? various-refs)
|
||||
|
@ -90,7 +88,7 @@
|
|||
|
||||
(define (recursive-local-define name value)
|
||||
(let ((parent (reverse! (cdr (reverse name)))))
|
||||
(and parent (make-modules-in (current-module) parent))
|
||||
(local-define name value)))
|
||||
(module-define! (make-modules-in (current-module) parent)
|
||||
name value)))
|
||||
|
||||
;;; ls.scm ends here
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2000, 2001, 2006, 2010 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
|
||||
|
@ -31,9 +31,10 @@
|
|||
|
||||
load))
|
||||
|
||||
(module-use! %module-public-interface (resolve-interface '(ice-9 safe-r5rs)))
|
||||
(module-use! (module-public-interface (current-module))
|
||||
(resolve-interface '(ice-9 safe-r5rs)))
|
||||
|
||||
(define scheme-report-interface %module-public-interface)
|
||||
(define scheme-report-interface (module-public-interface (current-module)))
|
||||
|
||||
(define (scheme-report-environment n)
|
||||
(if (not (= n 5))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
;;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2010 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
|
||||
|
@ -129,7 +129,8 @@
|
|||
|
||||
(define null-interface (resolve-interface '(ice-9 null)))
|
||||
|
||||
(module-use! %module-public-interface null-interface)
|
||||
(module-use! (module-public-interface (current-module))
|
||||
null-interface)
|
||||
|
||||
(define (null-environment n)
|
||||
(if (not (= n 5))
|
||||
|
|
|
@ -404,8 +404,7 @@ It is an image under the mapping EXTRACT."
|
|||
identity))
|
||||
|
||||
(define (root-modules)
|
||||
(cons the-root-module
|
||||
(submodules (nested-ref the-root-module '(app modules)))))
|
||||
(submodules (resolve-module '() #f)))
|
||||
|
||||
(define (submodules m)
|
||||
(hash-fold (lambda (name var data)
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;; installed-scm-file
|
||||
|
||||
;;;; Copyright (C) 2000,2001,2002, 2006, 2009 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010 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
|
||||
|
@ -848,10 +848,12 @@
|
|||
(close-port port)
|
||||
objects))
|
||||
|
||||
(define iface (module-public-interface (current-module)))
|
||||
|
||||
(define-method (load-objects (file <input-port>))
|
||||
(let ((m (make-module)))
|
||||
(module-use! m the-scm-module)
|
||||
(module-use! m %module-public-interface)
|
||||
(module-use! m iface)
|
||||
(save-module-excursion
|
||||
(lambda ()
|
||||
(set-current-module m)
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;; installed-scm-file
|
||||
|
||||
;;;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2005, 2006, 2010 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
|
||||
|
@ -28,4 +28,5 @@
|
|||
((_ arg ...)
|
||||
(define-class-with-accessors-keywords arg ...))))
|
||||
|
||||
(module-use! %module-public-interface (resolve-interface '(oop goops)))
|
||||
(module-use! (module-public-interface (current-module))
|
||||
(resolve-interface '(oop goops)))
|
||||
|
|
|
@ -34,9 +34,9 @@
|
|||
|
||||
;; Export all bindings that are exported from (oop goops)...
|
||||
(module-for-each (lambda (sym var)
|
||||
(module-add! %module-public-interface sym var))
|
||||
(nested-ref the-root-module '(%app modules oop goops
|
||||
%module-public-interface)))
|
||||
(module-add! (module-public-interface (current-module))
|
||||
sym var))
|
||||
(resolve-interface '(oop goops)))
|
||||
|
||||
;; ...but replace the following bindings:
|
||||
(export define-class define-method)
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2009, 2010 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
|
||||
|
@ -62,8 +62,8 @@
|
|||
(lp (1+ i) (if v (cons-uniq v out) out))))
|
||||
((,mod ,sym ,public?)
|
||||
;; hm, hacky.
|
||||
(let* ((m (nested-ref the-root-module
|
||||
(append '(%app modules) mod)))
|
||||
(let* ((m (nested-ref-module (resolve-module '() #f)
|
||||
mod))
|
||||
(v (and m
|
||||
(module-variable
|
||||
(if public?
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue