root/src/module.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. module_print
  2. init_module
  3. make_module
  4. lookup_module
  5. lookup_module_create
  6. Scm_MakeModule
  7. Scm_FindBinding
  8. Scm_SymbolValue
  9. Scm_Define
  10. Scm_DefineConst
  11. Scm_ImportModules
  12. Scm_ExportSymbols
  13. Scm_ExportAll
  14. Scm_ExtendModule
  15. Scm_FindModule
  16. Scm_AllModules
  17. Scm_SelectModule
  18. Scm_ModuleNameToPath
  19. Scm_PathToModuleName
  20. Scm_NullModule
  21. Scm_SchemeModule
  22. Scm_GaucheModule
  23. Scm_GaucheInternalModule
  24. Scm_UserModule
  25. Scm_CurrentModule
  26. Scm__InitModule

   1 /*
   2  * module.c - module implementation
   3  *
   4  *   Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
   5  * 
   6  *   Redistribution and use in source and binary forms, with or without
   7  *   modification, are permitted provided that the following conditions
   8  *   are met:
   9  * 
  10  *   1. Redistributions of source code must retain the above copyright
  11  *      notice, this list of conditions and the following disclaimer.
  12  *
  13  *   2. Redistributions in binary form must reproduce the above copyright
  14  *      notice, this list of conditions and the following disclaimer in the
  15  *      documentation and/or other materials provided with the distribution.
  16  *
  17  *   3. Neither the name of the authors nor the names of its contributors
  18  *      may be used to endorse or promote products derived from this
  19  *      software without specific prior written permission.
  20  *
  21  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  27  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  28  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  29  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  30  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  31  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32  *
  33  *  $Id: module.c,v 1.60 2005/10/13 08:14:13 shirok Exp $
  34  */
  35 
  36 #define LIBGAUCHE_BODY
  37 #include "gauche.h"
  38 #include "gauche/builtin-syms.h"
  39 
  40 /*
  41  * Modules
  42  *
  43  *  A module maps symbols to global locations.
  44  *  The mapping is resolved at the compile time.
  45  *  Scheme's current-module is therefore a syntax, instead of
  46  *  a procedure, to capture compile-time information.
  47  *
  48  *  Modules are registered to global hash table using their names
  49  *  as keys, so that the module is retrieved by its name.  The exception
  50  *  is "anonymous modules", which have '#' as the name field
  51  *  and not registered in the global table.   Anonymous modules are especially
  52  *  useful for certain applications that need temporary, segregated
  53  *  namespace---for example, a 'sandbox' environment to evaluate an
  54  *  expression sent over the network during a session.
  55  *  The anonymous namespace will be garbage-collected if nobody references
  56  *  it, recovering its resouces.
  57  */
  58 
  59 /* Mutex of module operation
  60  *
  61  * [SK] Each module used to have a mutex for accesses to it.  I changed it
  62  * to use a single global lock (modules.mutex), based on the following
  63  * observations:
  64  *
  65  *  - Profiling showed mutex_lock was taking around 10% of program loading
  66  *    phase in the previous version.
  67  *
  68  *  - Module operations almost always occur during program loading and
  69  *    interactive session.  Having giant lock for module operations won't
  70  *    affect normal runtime performance.
  71  *
  72  * Benchmark showed the change made program loading 30% faster.
  73  */
  74 
  75 static void module_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
  76 {
  77     Scm_Printf(port, "#<module %A>", SCM_MODULE(obj)->name);
  78 }
  79 
  80 SCM_DEFINE_BUILTIN_CLASS(Scm_ModuleClass,
  81                          module_print, NULL, NULL, NULL,
  82                          SCM_CLASS_COLLECTION_CPL);
  83 
  84 /* Global module table */
  85 static struct {
  86     ScmObj anon_name;       /* Name used for anonymous modules.
  87                                Symbol '#', set by init */
  88     ScmHashTable *table;    /* Maps name -> module. */
  89     ScmInternalMutex mutex; /* Lock for table.  Only register_module and
  90                                lookup_module may hold the lock. */
  91 } modules = { SCM_UNBOUND, NULL };
  92 
  93 /* Predefined modules - slots will be initialized by Scm__InitModule */
  94 #define DEFINE_STATIC_MODULE(cname) \
  95     static ScmModule cname = { { NULL } }
  96 
  97 DEFINE_STATIC_MODULE(nullModule);     /* #<module null> */
  98 DEFINE_STATIC_MODULE(schemeModule);   /* #<module scheme> */
  99 DEFINE_STATIC_MODULE(gaucheModule);   /* #<module gauche> */
 100 DEFINE_STATIC_MODULE(internalModule); /* #<module gauche.internal> */
 101 DEFINE_STATIC_MODULE(gfModule);       /* #<module gauche.gf> */
 102 DEFINE_STATIC_MODULE(userModule);     /* #<module user> */
 103 
 104 static ScmObj defaultParents = SCM_NIL; /* will be initialized */
 105 static ScmObj defaultMpl =     SCM_NIL; /* will be initialized */
 106 
 107 /*----------------------------------------------------------------------
 108  * Constructor
 109  */
 110 
 111 static void init_module(ScmModule *m, ScmSymbol *name)
 112 {
 113     m->name = name;
 114     m->imported = m->exported = SCM_NIL;
 115     m->exportAll = FALSE;
 116     m->parents = defaultParents;
 117     m->mpl = Scm_Cons(SCM_OBJ(m), defaultMpl);
 118     m->table = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 0));
 119 }
 120 
 121 /* Internal */
 122 static ScmObj make_module(ScmSymbol *name)
 123 {
 124     ScmModule *m;
 125     m = SCM_NEW(ScmModule);
 126     SCM_SET_CLASS(m, SCM_CLASS_MODULE);
 127     init_module(m, name);
 128     return SCM_OBJ(m);
 129 }
 130 
 131 /* Internal.  Lookup module with name N from the table. */
 132 static ScmModule *lookup_module(ScmSymbol *name)
 133 {
 134     ScmHashEntry *e;
 135     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 136     e = Scm_HashTableGet(modules.table, SCM_OBJ(name));
 137     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 138     if (e) return SCM_MODULE(e->value);
 139     else return NULL;
 140 }
 141 
 142 /* Internal.  Lookup module, and if there's none, create one. */
 143 static ScmModule *lookup_module_create(ScmSymbol *name, int *created)
 144 {
 145     ScmHashEntry *e;
 146     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 147     e = Scm_HashTableAdd(modules.table, SCM_OBJ(name), SCM_FALSE);
 148     if (e->value == SCM_FALSE) {
 149         e->value = make_module(name);
 150         *created = TRUE;
 151     } else {
 152         *created = FALSE;
 153     }
 154     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 155     return SCM_MODULE(e->value);
 156 }
 157 
 158 ScmObj Scm_MakeModule(ScmSymbol *name, int error_if_exists)
 159 {
 160     ScmObj r;
 161     if (name == NULL) name = SCM_SYMBOL(modules.anon_name);
 162     if (SCM_EQ(SCM_OBJ(name), modules.anon_name)) {
 163         r = make_module(name);
 164     } else {
 165         int created;
 166         r = SCM_OBJ(lookup_module_create(name, &created));
 167         if (!created) {
 168             if (error_if_exists) {
 169                 Scm_Error("couldn't create module '%S': named module already exists",
 170                           SCM_OBJ(name));
 171             } else {
 172                 r = SCM_FALSE;
 173             }
 174         }
 175     }
 176     return r;
 177 }
 178 
 179 /*----------------------------------------------------------------------
 180  * Finding and modifying bindings
 181  */
 182 
 183 #define SEARCHED_ARRAY_SIZE  64
 184 
 185 ScmGloc *Scm_FindBinding(ScmModule *module, ScmSymbol *symbol,
 186                          int stay_in_module)
 187 {
 188     ScmHashEntry *e;
 189     ScmModule *m = module;
 190     ScmObj p, mp;
 191     ScmGloc *gloc = NULL;
 192 
 193     /* keep record of searched modules.  we use stack array for small # of
 194        modules, in order to avoid consing for typical cases. */
 195     ScmObj searched[SEARCHED_ARRAY_SIZE];
 196     int num_searched = 0, i;
 197     ScmObj more_searched = SCM_NIL;
 198 
 199     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 200 
 201     /* first, search from the specified module.
 202        NB: we directly check gloc->value instead of calling
 203        SCM_GLOC_GET, since this check is merely to eliminate
 204        the GLOC inserted by export. */
 205     e = Scm_HashTableGet(m->table, SCM_OBJ(symbol));
 206     if (e) {
 207         gloc = SCM_GLOC(e->value);
 208         if (!SCM_UNBOUNDP(gloc->value)) goto found;
 209     }
 210     
 211     if (!stay_in_module) {
 212         /* Next, search from imported modules */
 213         SCM_FOR_EACH(p, module->imported) {
 214             SCM_ASSERT(SCM_MODULEP(SCM_CAR(p)));
 215             SCM_FOR_EACH(mp, SCM_MODULE(SCM_CAR(p))->mpl) {
 216                 ScmGloc *g;
 217                 
 218                 SCM_ASSERT(SCM_MODULEP(SCM_CAR(mp)));
 219                 
 220                 for (i=0; i<num_searched; i++) {
 221                     if (SCM_EQ(SCM_CAR(mp), searched[i])) goto skip;
 222                 }
 223                 if (!SCM_NULLP(more_searched)) {
 224                     if (!SCM_FALSEP(Scm_Memq(SCM_CAR(mp), more_searched))) {
 225                         goto skip;
 226                     }
 227                 }
 228                 
 229                 m = SCM_MODULE(SCM_CAR(mp));
 230                 e = Scm_HashTableGet(m->table, SCM_OBJ(symbol));
 231                 /* see above comment about the check of gloc->value */
 232                 if (e && (g = SCM_GLOC(e->value))->exported
 233                     && !SCM_UNBOUNDP(g->value)) {
 234                     gloc = g;
 235                     goto found;
 236                 }
 237 
 238                 if (num_searched < SEARCHED_ARRAY_SIZE) {
 239                     searched[num_searched++] = SCM_OBJ(m);
 240                 } else {
 241                     more_searched = Scm_Cons(SCM_OBJ(m), more_searched);
 242                 }
 243             }
 244           skip:;
 245         }
 246         /* Then, search from parent modules */
 247         SCM_ASSERT(SCM_PAIRP(module->mpl));
 248         SCM_FOR_EACH(mp, SCM_CDR(module->mpl)) {
 249             SCM_ASSERT(SCM_MODULEP(SCM_CAR(mp)));
 250             m = SCM_MODULE(SCM_CAR(mp));
 251             e = Scm_HashTableGet(m->table, SCM_OBJ(symbol));
 252             if (e) { gloc = SCM_GLOC(e->value); goto found; }
 253         }
 254     }
 255   found:
 256     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 257     return gloc;
 258 }
 259 
 260 ScmObj Scm_SymbolValue(ScmModule *module, ScmSymbol *symbol)
 261 {
 262     ScmGloc *g = Scm_FindBinding(module, symbol, FALSE);
 263     if (g == NULL) return SCM_UNBOUND;
 264     else return SCM_GLOC_GET(g);
 265 }
 266 
 267 /*
 268  * Definition.
 269  *  TODO: consolidate the common code between Scm_Define and Scm_DefineConst.
 270  */
 271 ScmObj Scm_Define(ScmModule *module, ScmSymbol *symbol, ScmObj value)
 272 {
 273     ScmGloc *g;
 274     ScmHashEntry *e;
 275     int redefining = FALSE;
 276     
 277     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 278     e = Scm_HashTableGet(module->table, SCM_OBJ(symbol));
 279     if (e) {
 280         g = SCM_GLOC(e->value);
 281         if (SCM_GLOC_CONST_P(g)) {
 282             redefining = TRUE;
 283             g->setter = NULL;
 284         }
 285         SCM_GLOC_SET(g, value);
 286     } else {
 287         g = SCM_GLOC(Scm_MakeGloc(symbol, module));
 288         SCM_GLOC_SET(g, value);
 289         Scm_HashTablePut(module->table, SCM_OBJ(symbol), SCM_OBJ(g));
 290         /* If module is marked 'export-all', export this binding by default */
 291         if (module->exportAll) {
 292             g->exported = TRUE;
 293             module->exported = Scm_Cons(SCM_OBJ(g->name), module->exported);
 294         }
 295     }
 296     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 297     
 298     if (redefining) {
 299         Scm_Warn("redefining constant %S::%S", g->module, g->name);
 300     }
 301     return SCM_OBJ(g);
 302 }
 303 
 304 ScmObj Scm_DefineConst(ScmModule *module, ScmSymbol *symbol, ScmObj value)
 305 {
 306     ScmGloc *g;
 307     ScmHashEntry *e;
 308     ScmObj oldval = SCM_UNDEFINED;
 309     int redefining = FALSE;
 310 
 311     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 312     e = Scm_HashTableGet(module->table, SCM_OBJ(symbol));
 313     /* NB: this function bypasses check of gloc setter */
 314     if (e) {
 315         g = SCM_GLOC(e->value);
 316         if (SCM_GLOC_CONST_P(g)) {
 317             redefining = TRUE;
 318             oldval = g->value;
 319         }
 320         g->setter = Scm_GlocConstSetter;
 321         g->value  = value;
 322     } else {
 323         g = SCM_GLOC(Scm_MakeConstGloc(symbol, module));
 324         g->value = value;
 325         Scm_HashTablePut(module->table, SCM_OBJ(symbol), SCM_OBJ(g));
 326         /* If module is marked 'export-all', export this binding by default */
 327         if (module->exportAll) {
 328             g->exported = TRUE;
 329             module->exported = Scm_Cons(SCM_OBJ(g->name), module->exported);
 330         }
 331     }
 332     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 333 
 334     if (redefining && !Scm_EqualP(value, oldval)) {
 335         Scm_Warn("redefining constant %S::%S", g->module->name, g->name);
 336     }
 337     return SCM_OBJ(g);
 338 }
 339 
 340 ScmObj Scm_ImportModules(ScmModule *module, ScmObj list)
 341 {
 342     ScmObj lp;
 343     ScmModule *mod;
 344     ScmSymbol *name = NULL;
 345     SCM_FOR_EACH(lp, list) {
 346         if (SCM_SYMBOLP(SCM_CAR(lp))) {
 347             name = SCM_SYMBOL(SCM_CAR(lp));
 348         } else if (SCM_IDENTIFIERP(SCM_CAR(lp))) {
 349             name = SCM_IDENTIFIER(SCM_CAR(lp))->name;
 350         } else {
 351             Scm_Error("module name required, but got %S", SCM_CAR(lp));
 352         }
 353         mod = Scm_FindModule(name, 0);
 354         (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 355         module->imported =
 356             Scm_Cons(SCM_OBJ(mod),
 357                      Scm_DeleteX(SCM_OBJ(mod), module->imported, SCM_CMP_EQ));
 358         (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 359     }
 360     return module->imported;
 361 }
 362 
 363 ScmObj Scm_ExportSymbols(ScmModule *module, ScmObj list)
 364 {
 365     ScmObj lp, syms, badsym = SCM_FALSE;
 366     int error = FALSE;
 367     ScmSymbol *s;
 368     ScmHashEntry *e;
 369     ScmGloc *g;
 370 
 371     /* We used to do something like
 372      *  (set! (module-exports module)
 373      *        (delete-duplicates (union (module-exports module) list)))
 374      * This is slow when we export lots of symbols.  As of 0.8.6,
 375      * each GLOC has exported flag, so we can check whether a binding
 376      * is exported or not in O(1).   Module-exports list is kept
 377      * for backward compatibility.
 378      */
 379     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 380     syms = module->exported;
 381     SCM_FOR_EACH(lp, list) {
 382         if (!SCM_SYMBOLP(SCM_CAR(lp))) {
 383             error = TRUE;
 384             badsym = SCM_CAR(lp);
 385             break;
 386         }
 387         s = SCM_SYMBOL(SCM_CAR(lp));
 388         e = Scm_HashTableAdd(module->table, SCM_OBJ(s), SCM_UNBOUND);
 389         if (SCM_GLOCP(e->value)) {
 390             g = SCM_GLOC(e->value);
 391             if (!g->exported) {
 392                 syms = Scm_Cons(SCM_OBJ(s), syms);
 393                 g->exported = TRUE;
 394             }
 395         } else {
 396             g = SCM_GLOC(Scm_MakeGloc(s, module));
 397             g->exported = TRUE;
 398             e->value = SCM_OBJ(g);
 399             syms = Scm_Cons(SCM_OBJ(s), syms);
 400         }
 401     }
 402     if (!error) module->exported = syms;
 403     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 404     if (error) Scm_Error("symbol required, but got %S", badsym);
 405     return syms;
 406 }
 407 
 408 ScmObj Scm_ExportAll(ScmModule *module)
 409 {
 410     ScmHashIter iter;
 411     ScmHashEntry *e;
 412     
 413     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 414     if (!module->exportAll) {
 415         /* Mark the module 'export-all' so that the new bindings would get
 416            exported mark by default. */
 417         module->exportAll = TRUE;
 418         
 419         /* Scan the module and mark all existing bindings as exported. */
 420         Scm_HashIterInit(module->table, &iter);
 421         while ((e = Scm_HashIterNext(&iter)) != NULL) {
 422             ScmGloc *g = SCM_GLOC(e->value);
 423             if (!g->exported) {
 424                 g->exported = TRUE;
 425                 module->exported =
 426                     Scm_Cons(SCM_OBJ(g->name), module->exported);
 427             }
 428         }
 429     }
 430     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 431     return SCM_OBJ(module);
 432 }
 433 
 434 /*----------------------------------------------------------------------
 435  * Extending (inheriting) modules
 436  */
 437 
 438 /* Module inheritance obeys the same rule as class inheritance,
 439    hence we use monotonic merge. */
 440 /* NB: ExtendModule alters module's precedence list, and may cause
 441    unwanted side effects when used carelessly.  */
 442 
 443 ScmObj Scm_ExtendModule(ScmModule *module, ScmObj supers)
 444 {
 445     ScmObj mpl, seqh = SCM_NIL, seqt = SCM_NIL, sp;
 446 
 447     SCM_FOR_EACH(sp, supers) {
 448         if (!SCM_MODULEP(SCM_CAR(sp))) {
 449             Scm_Error("non-module object found in the extend syntax: %S",
 450                       SCM_CAR(sp));
 451         }
 452         SCM_APPEND1(seqh, seqt, SCM_MODULE(SCM_CAR(sp))->mpl);
 453     }
 454     SCM_APPEND1(seqh, seqt, supers);
 455     module->parents = supers;
 456     mpl = Scm_MonotonicMerge(SCM_OBJ(module), seqh);
 457     if (SCM_FALSEP(mpl)) {
 458         Scm_Error("can't extend those modules simultaneously because of inconsistent precedence lists: %S", supers);
 459     }
 460     module->mpl = mpl;
 461     return mpl;
 462 }
 463 
 464 /*----------------------------------------------------------------------
 465  * Finding modules
 466  */
 467 
 468 ScmModule *Scm_FindModule(ScmSymbol *name, int flags)
 469 {
 470     ScmModule *m;
 471     int created;
 472 
 473     if (flags & SCM_FIND_MODULE_CREATE) {
 474         m = lookup_module_create(name, &created);
 475         SCM_ASSERT(m != NULL);
 476         return m;
 477     } else {
 478         m = lookup_module(name);
 479         if (m == NULL) {
 480             if (flags & SCM_FIND_MODULE_QUIET) {
 481                 return NULL;
 482             } else {
 483                 Scm_Error("no such module: %S", name);
 484             }
 485         } else {
 486             return m;
 487         }
 488     }
 489 }
 490 
 491 ScmObj Scm_AllModules(void)
 492 {
 493     ScmObj h = SCM_NIL, t = SCM_NIL;
 494     ScmHashIter iter;
 495     ScmHashEntry *e;
 496 
 497     (void)SCM_INTERNAL_MUTEX_LOCK(modules.mutex);
 498     Scm_HashIterInit(modules.table, &iter);
 499     while ((e = Scm_HashIterNext(&iter)) != NULL) {
 500         SCM_APPEND1(h, t, e->value);
 501     }
 502     (void)SCM_INTERNAL_MUTEX_UNLOCK(modules.mutex);
 503     return h;
 504 }
 505 
 506 void Scm_SelectModule(ScmModule *mod)
 507 {
 508     SCM_ASSERT(SCM_MODULEP(mod));
 509     Scm_VM()->module = mod;
 510 }
 511 
 512 /*----------------------------------------------------------------------
 513  * Module and pathnames
 514  */
 515 
 516 /* Convert module name and pathname (mod load-path) and vice versa.
 517    The default conversion is pretty straightforward, e.g.
 518    util.list <=> "util/list"  etc.  However, modules and files can
 519    have many-to-many mapping, and I'd like to reserve the room
 520    of future extensions.   Eventually there will be some special
 521    mapping table so the programmer can register exceptional mappings. */
 522 
 523 ScmObj Scm_ModuleNameToPath(ScmSymbol *name)
 524 {
 525     const ScmStringBody *b = SCM_STRING_BODY(SCM_SYMBOL_NAME(name));
 526     char *buf = SCM_NEW_ATOMIC2(char *, SCM_STRING_BODY_SIZE(b)+1);
 527     char *p = buf, *e = buf + SCM_STRING_BODY_SIZE(b);
 528     memcpy(buf, SCM_STRING_BODY_START(b), SCM_STRING_BODY_SIZE(b));
 529     while (p < e) {
 530         int n = SCM_CHAR_NFOLLOWS(*p);
 531         if (*p == '.') *p++ = '/';
 532         else p += n+1;
 533     }
 534     *e = '\0';
 535     return Scm_MakeString(buf, SCM_STRING_BODY_SIZE(b),
 536                           SCM_STRING_BODY_LENGTH(b), 0);
 537 }
 538 
 539 ScmObj Scm_PathToModuleName(ScmString *path)
 540 {
 541     const ScmStringBody *b = SCM_STRING_BODY(path);
 542     char *buf = SCM_NEW_ATOMIC2(char *, SCM_STRING_BODY_SIZE(b)+1);
 543     char *p = buf, *e = buf + SCM_STRING_BODY_SIZE(b);
 544     memcpy(buf, SCM_STRING_BODY_START(b), SCM_STRING_BODY_SIZE(b));
 545     while (p < e) {
 546         int n = SCM_CHAR_NFOLLOWS(*p);
 547         if (*p == '/') *p++ = '.';
 548         else if (*p == '.') Scm_Error("bad pathname for module path: %S", path);
 549         else p += n+1;
 550     }
 551     *e = '\0';
 552     return SCM_INTERN(buf);
 553 }
 554 
 555 
 556 /*----------------------------------------------------------------------
 557  * Predefined modules and initialization
 558  */
 559 
 560 ScmModule *Scm_NullModule(void)
 561 {
 562     return &nullModule;
 563 }
 564 
 565 ScmModule *Scm_SchemeModule(void)
 566 {
 567     return &schemeModule;
 568 }
 569 
 570 ScmModule *Scm_GaucheModule(void)
 571 {
 572     return &gaucheModule;
 573 }
 574 
 575 ScmModule *Scm_GaucheInternalModule(void)
 576 {
 577     return &internalModule;
 578 }
 579 
 580 ScmModule *Scm_UserModule(void)
 581 {
 582     return &userModule;
 583 }
 584 
 585 ScmModule *Scm_CurrentModule(void)
 586 {
 587     return Scm_VM()->module;
 588 }
 589 
 590 /* NB: we don't need to lock the global module table in initialization */
 591 #define INIT_MOD(mod, mname, mpl)                                           \
 592     do {                                                                    \
 593         SCM_SET_CLASS(&mod, SCM_CLASS_MODULE);                              \
 594         init_module(&mod, SCM_SYMBOL(mname));                               \
 595         Scm_HashTablePut(modules.table, SCM_OBJ((mod).name), SCM_OBJ(&mod));\
 596         mod.parents = (SCM_NULLP(mpl)? SCM_NIL : SCM_LIST1(SCM_CAR(mpl)));  \
 597         mpl = mod.mpl = Scm_Cons(SCM_OBJ(&mod), mpl);                       \
 598     } while (0)
 599 
 600 void Scm__InitModule(void)
 601 {
 602     ScmObj mpl = SCM_NIL;
 603 
 604     (void)SCM_INTERNAL_MUTEX_INIT(modules.mutex);
 605     modules.table = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 64));
 606 
 607     /* standard module chain */
 608     INIT_MOD(nullModule, SCM_SYM_NULL, mpl);
 609     INIT_MOD(schemeModule, SCM_SYM_SCHEME, mpl);
 610     INIT_MOD(gaucheModule, SCM_SYM_GAUCHE, mpl);
 611     INIT_MOD(gfModule, SCM_SYM_GAUCHE_GF, mpl);
 612     INIT_MOD(userModule, SCM_SYM_USER, mpl);
 613 
 614     mpl = SCM_CDR(mpl);  /* default mpl doesn't include user module */
 615     defaultParents = SCM_LIST1(SCM_CAR(mpl));
 616     defaultMpl = mpl;
 617     modules.anon_name = SCM_SYM_SHARP;
 618 
 619     /* other modules */
 620     mpl = defaultMpl;
 621     INIT_MOD(internalModule, SCM_SYM_GAUCHE_INTERNAL, mpl);
 622 }

/* [<][>][^][v][top][bottom][index][help] */