Kouhei Sutou
kou****@cozmi*****
2004年 3月 28日 (日) 17:04:50 JST
須藤です．
私は，あまりSchemeに慣れ親しんでいるわけではないので変な事を
いっているかもしれませんが，現在のgeneric functionがいまいち
使いづらいです．
(1) 例えば，
(define-module a
(export x)
(define-method x ((y <list>)) #f))
(define-module b
(export x)
(define-method x ((y <string>)) #f))
と定義されていたときに，
(import a)
としても
(import b)
としても
x ; => #<generic x (2)>
となって欲しいです．
# generic functionはグローバルに見えて欲しいというのは変？
現在は，
(import a)
x ; => #<generic x (1)> for (<list>)
で，
(import b)
x ; => #<generic x (1)> for (<string>)
となります．
(2) もうひとつ，
(define-module c
(export z)
(define-method z ((y <list>)) #f))
(define-module d
(import c)
(export z)
(define-method z ((y <string>)) #f))
(import d)
としたときに，
z ; => #<generic z (2)>
となって欲しいです．
現在は，
z ; => *** ERROR: unbound variable: z
となります．
http://www.shiro.dreamhost.com/scheme/wiliki/wiliki.cgi?Gauche%3aGenericFunction%a4%c8Module
に(あまり綺麗はでないと)書かれている解決法と大体同じ方法です
が，こんなのはいかがでしょうか．
* gauche.gfはgeneric functionのテーブルを持つ．
define-methodはgauche.gfにあるgeneric functionにメソッド
を追加する． => (1)が解決．
gauche.gfにgeneric functionの束縛を導入しないので，明示
的にimportとかdefine-methodとかしない限りはgeneric
function の実体は見えない．
* define-methodしたとき，現在のmoduleでgeneric function名
がgeneric fucntionの実体に束縛されていなければ，現在の
moduleに束縛を導入する． => (2)が解決．
Index: src/gauche.h
===================================================================
RCS file: /cvsroot/gauche/Gauche/src/gauche.h,v
retrieving revision 1.367
diff -u -p -r1.367 gauche.h
--- src/gauche.h 5 Feb 2004 03:01:23 -0000 1.367
+++ src/gauche.h 28 Mar 2004 07:30:38 -0000
@@ -1550,7 +1550,10 @@ SCM_EXTERN ScmModule *Scm_NullModule(voi
SCM_EXTERN ScmModule *Scm_SchemeModule(void);
SCM_EXTERN ScmModule *Scm_GaucheModule(void);
SCM_EXTERN ScmModule *Scm_UserModule(void);
+SCM_EXTERN ScmModule *Scm_GFModule(void);
SCM_EXTERN ScmModule *Scm_CurrentModule(void);
+
+SCM_EXTERN ScmHashTable *Scm_GFHashTable(void);
#define SCM_DEFINE(module, cstr, val) \
Scm_Define(SCM_MODULE(module), \
Index: src/module.c
===================================================================
RCS file: /cvsroot/gauche/Gauche/src/module.c,v
retrieving revision 1.47
diff -u -p -r1.47 module.c
--- src/module.c 18 Jan 2004 12:07:31 -0000 1.47
+++ src/module.c 28 Mar 2004 07:30:38 -0000
@@ -470,11 +470,26 @@ ScmModule *Scm_UserModule(void)
return &userModule;
}
+ScmModule *Scm_GFModule(void)
+{
+ return &gfModule;
+}
+
ScmModule *Scm_CurrentModule(void)
{
return Scm_VM()->module;
}
+static ScmSymbol *Scm_GFTableSymbol(void)
+{
+ return SCM_SYMBOL(SCM_INTERN("*gf-table*"));
+}
+
+ScmHashTable *Scm_GFHashTable(void)
+{
+ return SCM_HASHTABLE(Scm_SymbolValue(Scm_GFModule(), Scm_GFTableSymbol()));
+}
+
/* NB: we don't need to lock the global module table in initialization */
#define INIT_MOD(mod, mname, mpl) \
do { \
@@ -496,6 +511,8 @@ void Scm__InitModule(void)
INIT_MOD(schemeModule, SCM_SYM_SCHEME, mpl);
INIT_MOD(gaucheModule, SCM_SYM_GAUCHE, mpl);
INIT_MOD(gfModule, SCM_SYM_GAUCHE_GF, mpl);
+ Scm_Define(Scm_GFModule(), Scm_GFTableSymbol(),
+ Scm_MakeHashTable(SCM_HASH_ADDRESS, NULL, 64));
INIT_MOD(userModule, SCM_SYM_USER, mpl);
mpl = SCM_CDR(mpl); /* default mpl doesn't include user module */
Index: src/moplib.stub
===================================================================
RCS file: /cvsroot/gauche/Gauche/src/moplib.stub,v
retrieving revision 1.24
diff -u -p -r1.24 moplib.stub
--- src/moplib.stub 12 Nov 2003 14:15:50 -0000 1.24
+++ src/moplib.stub 28 Mar 2004 07:30:38 -0000
@@ -52,16 +52,44 @@
}
"
+"static ScmObj symbol_value_in_module(ScmModule *module, ScmSymbol *symbol)
+ {
+ ScmGloc *g = Scm_FindBinding(module, symbol, TRUE);
+ if (g == NULL) return SCM_UNBOUND;
+ else return SCM_GLOC_GET(g);
+ }
+"
+
(define-cproc %ensure-generic-function (name::<symbol> module::<module>)
- " ScmObj val = Scm_SymbolValue(module, name);
+ " ScmObj val = symbol_value_in_module(module, name);
+ ScmHashEntry *e;
+ ScmModule *gf_module;
+
+ if (Scm_TypeP(val, SCM_CLASS_GENERIC))
+ SCM_RETURN(val);
+ else
+ val = Scm_SymbolValue(module, name);
+
+ if (!Scm_TypeP(val, SCM_CLASS_GENERIC)) {
+ gf_module = Scm_GFModule();
+ (void)SCM_INTERNAL_MUTEX_LOCK(gf_module->mutex);
+ e = Scm_HashTableGet(Scm_GFHashTable(), SCM_OBJ(name));
+ (void)SCM_INTERNAL_MUTEX_UNLOCK(gf_module>mutex);
+ if (e)
+ val = e->value;
+ }
+
if (!Scm_TypeP(val, SCM_CLASS_GENERIC)) {
if (SCM_SUBRP(val) || SCM_CLOSUREP(val)) {
val = Scm_MakeBaseGeneric(SCM_OBJ(name), call_fallback_proc, val);
} else {
val = Scm_MakeBaseGeneric(SCM_OBJ(name), NULL, NULL);
}
- Scm_Define(module, name, val);
+ (void)SCM_INTERNAL_MUTEX_LOCK(gf_module>mutex);
+ Scm_HashTablePut(Scm_GFHashTable(), SCM_OBJ(name), val);
+ (void)SCM_INTERNAL_MUTEX_UNLOCK(gf_module->mutex);
}
+ Scm_Define(module, name, val);
SCM_RETURN(val);")
(define-cproc %make-next-method (gf methods::<list> args::<list>)