1 /*
2 * load.c - load a program
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
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
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/class.h"
37 #include "gauche/port.h"
38 #include "gauche/priv/builtin-syms.h"
39 #include "gauche/priv/readerP.h"
40 #include "gauche/priv/portP.h"
41 #include "gauche/priv/moduleP.h"
42
43 #include <ctype.h>
44 #include <fcntl.h>
45
46 /*
47 * Load file.
48 */
49
50 /* Static parameters */
51 static struct {
52 /* Load path list */
53 ScmGloc *load_path_rec; /* *load-path* */
54 ScmGloc *dynload_path_rec; /* *dynamic-load-path* */
55 ScmGloc *load_suffixes_rec; /* *load-suffixes* */
56 ScmGloc *load_path_hooks_rec; /* *load-path-hooks* */
57 ScmInternalMutex path_mutex;
58
59 /* Provided features */
60 ScmObj provided; /* List of provided features. */
61 ScmObj providing; /* Alist of features that is being loaded,
62 and the thread that is loading it. */
63 ScmObj waiting; /* Alist of threads that is waiting for
64 a feature to being provided, and the
65 feature that is waited. */
66 ScmInternalMutex prov_mutex;
67 ScmInternalCond prov_cv;
68
69 /* Dynamic environments kept during specific `load'. They are
70 thread-specific, and we use ScmParameter mechanism. */
71 ScmPrimitiveParameter *load_history; /* history of the nested load */
72 ScmPrimitiveParameter *load_next; /* list of the directories to be
73 searched. */
74 ScmPrimitiveParameter *load_port; /* current port from which we are
75 loading */
76
77 /* Dynamic linking */
78 ScmObj dso_suffixes;
79 ScmHashTable *dso_table; /* Hashtable path -> <dlobj> */
80 ScmObj dso_prelinked; /* List of 'prelinked' DSOs, that is, they
81 are already linked but pretened to be
82 DSOs. dynamic-load won't do anything.
83 NB: We assume initfns of prelinked DSOs
84 are already called by the application,
85 but we may change this design in future.
86 */
87 ScmInternalMutex dso_mutex;
88 } ldinfo;
89
90 /* keywords used for load and load-from-port surbs */
91 static ScmObj key_error_if_not_found = SCM_UNBOUND;
92 static ScmObj key_macro = SCM_UNBOUND;
93 static ScmObj key_ignore_coding = SCM_UNBOUND;
94 static ScmObj key_paths = SCM_UNBOUND;
95 static ScmObj key_environment = SCM_UNBOUND;
96 static ScmObj key_main_script = SCM_UNBOUND;
97
98 #define PARAM_REF(vm, loc) Scm_PrimitiveParameterRef(vm, ldinfo.loc)
99
100 /*
101 * ScmLoadPacket is the way to communicate to Scm_Load facility.
102 */
103
104 /* small utility. initializes OUT fields of the load packet. */
load_packet_prepare(ScmLoadPacket * packet)105 static void load_packet_prepare(ScmLoadPacket *packet)
106 {
107 if (packet) {
108 packet->exception = SCM_FALSE;
109 packet->loaded = FALSE;
110 }
111 }
112
113 /* for applications to initialize ScmLoadPacket before passing it to
114 Scm_Load or Scm_LoadFromPort. As of 0.9, ScmLoadPacket only has
115 fields to be filled by those APIs, so applications don't need to
116 initialize it explicitly. However, it is possible in future that
117 we add some fields to pass info from applications to APIs, in which
118 case it is necessary for this function to set appropriate initial
119 values for such fields. */
Scm_LoadPacketInit(ScmLoadPacket * p)120 void Scm_LoadPacketInit(ScmLoadPacket *p)
121 {
122 load_packet_prepare(p);
123 }
124
125 /*--------------------------------------------------------------------
126 * Scm_LoadFromPort
127 *
128 * The most basic function in the load()-family. Read an expression
129 * from the given port and evaluates it repeatedly, until it reaches
130 * EOF. Then the port is closed. The port is locked by the calling
131 * thread until the operation terminates.
132 *
133 * The result of the last evaluation remains on VM.
134 *
135 * No matter how the load terminates, either normal or abnormal,
136 * the port is closed, and the current module is restored to the
137 * one when load is called.
138 *
139 * FLAGS argument is ignored for now, but reserved for future
140 * extension. SCM_LOAD_QUIET_NOFILE and SCM_LOAD_IGNORE_CODING
141 * won't have any effect for LoadFromPort; see Scm_Load below.
142 *
143 * TODO: if we're using coding-aware port, how should we propagate
144 * locking into the wrapped (original) port?
145 */
146
Scm_LoadFromPort(ScmPort * port,u_long flags,ScmLoadPacket * packet)147 int Scm_LoadFromPort(ScmPort *port, u_long flags, ScmLoadPacket *packet)
148 {
149 static ScmObj load_from_port = SCM_UNDEFINED;
150 ScmObj args = SCM_NIL;
151 SCM_BIND_PROC(load_from_port, "load-from-port", Scm_GaucheModule());
152 load_packet_prepare(packet);
153
154 args = Scm_Cons(SCM_OBJ(port), args);
155
156 if (flags&SCM_LOAD_PROPAGATE_ERROR) {
157 Scm_ApplyRec(load_from_port, args);
158 if (packet) packet->loaded = TRUE;
159 return 0;
160 } else {
161 ScmEvalPacket eresult;
162 int r = Scm_Apply(load_from_port, args, &eresult);
163 if (packet) {
164 packet->exception = eresult.exception;
165 packet->loaded = (r >= 0);
166 }
167 return (r < 0)? -1 : 0;
168 }
169 }
170
171 /*---------------------------------------------------------------------
172 * Scm_Load
173 * Scm_VMLoad
174 *
175 * Scheme's load().
176 *
177 * filename - name of the file. can be sans suffix.
178 * load_paths - list of pathnames or #f. If #f, system's load path
179 * is used.
180 * env - a module where the forms are evaluated, or #f.
181 * If #f, the current module is used.
182 * flags - combination of ScmLoadFlags.
183 */
184
185 /* The real `load' function is moved to Scheme. This is a C stub to
186 call it. */
Scm_VMLoad(ScmString * filename,ScmObj paths,ScmObj env,int flags)187 ScmObj Scm_VMLoad(ScmString *filename, ScmObj paths, ScmObj env, int flags)
188 {
189 ScmObj opts = SCM_NIL;
190 static ScmObj load_proc = SCM_UNDEFINED;
191 SCM_BIND_PROC(load_proc, "load", Scm_SchemeModule());
192
193 if (flags&SCM_LOAD_QUIET_NOFILE) {
194 opts = Scm_Cons(key_error_if_not_found, Scm_Cons(SCM_FALSE, opts));
195 }
196 if (flags&SCM_LOAD_IGNORE_CODING) {
197 opts = Scm_Cons(key_ignore_coding, Scm_Cons(SCM_TRUE, opts));
198 }
199 if (flags&SCM_LOAD_MAIN_SCRIPT) {
200 opts = Scm_Cons(key_main_script, Scm_Cons(SCM_TRUE, opts));
201 }
202 if (SCM_NULLP(paths) || SCM_PAIRP(paths)) {
203 opts = Scm_Cons(key_paths, Scm_Cons(paths, opts));
204 }
205 if (!SCM_FALSEP(env)) {
206 opts = Scm_Cons(key_environment, Scm_Cons(env, opts));
207 }
208 return Scm_VMApply(load_proc, Scm_Cons(SCM_OBJ(filename), opts));
209 }
210
Scm_Load(const char * cpath,u_long flags,ScmLoadPacket * packet)211 int Scm_Load(const char *cpath, u_long flags, ScmLoadPacket *packet)
212 {
213 static ScmObj load_proc = SCM_UNDEFINED;
214 ScmObj f = SCM_MAKE_STR_COPYING(cpath);
215 ScmObj opts = SCM_NIL;
216 SCM_BIND_PROC(load_proc, "load", Scm_SchemeModule());
217
218 if (flags&SCM_LOAD_QUIET_NOFILE) {
219 opts = Scm_Cons(key_error_if_not_found, Scm_Cons(SCM_FALSE, opts));
220 }
221 if (flags&SCM_LOAD_IGNORE_CODING) {
222 opts = Scm_Cons(key_ignore_coding, Scm_Cons(SCM_TRUE, opts));
223 }
224 if (flags&SCM_LOAD_MAIN_SCRIPT) {
225 opts = Scm_Cons(key_main_script, Scm_Cons(SCM_TRUE, opts));
226 }
227
228 load_packet_prepare(packet);
229 if (flags&SCM_LOAD_PROPAGATE_ERROR) {
230 ScmObj r = Scm_ApplyRec(load_proc, Scm_Cons(f, opts));
231 if (packet) {
232 packet->loaded = !SCM_FALSEP(r);
233 }
234 return 0;
235 } else {
236 ScmEvalPacket eresult;
237 int r = Scm_Apply(load_proc, Scm_Cons(f, opts), &eresult);
238 if (packet) {
239 packet->exception = eresult.exception;
240 packet->loaded = (r > 0 && !SCM_FALSEP(eresult.results[0]));
241 }
242 return (r >= 0)? 0 : -1;
243 }
244 }
245
246 /* A convenience routine */
Scm_LoadFromCString(const char * program,u_long flags,ScmLoadPacket * p)247 int Scm_LoadFromCString(const char *program, u_long flags, ScmLoadPacket *p)
248 {
249 ScmObj ip = Scm_MakeInputStringPort(SCM_STRING(SCM_MAKE_STR(program)), TRUE);
250 return Scm_LoadFromPort(SCM_PORT(ip), flags, p);
251 }
252
253
254 /*
255 * Utilities
256 */
257
Scm_GetLoadPath(void)258 ScmObj Scm_GetLoadPath(void)
259 {
260 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.path_mutex);
261 ScmObj paths = Scm_CopyList(ldinfo.load_path_rec->value);
262 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.path_mutex);
263 return paths;
264 }
265
Scm_GetDynLoadPath(void)266 ScmObj Scm_GetDynLoadPath(void)
267 {
268 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.path_mutex);
269 ScmObj paths = Scm_CopyList(ldinfo.dynload_path_rec->value);
270 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.path_mutex);
271 return paths;
272 }
273
break_env_paths(const char * envname)274 static ScmObj break_env_paths(const char *envname)
275 {
276 const char *e = Scm_GetEnv(envname);
277 #ifndef GAUCHE_WINDOWS
278 char delim = ':';
279 #else /*GAUCHE_WINDOWS*/
280 char delim = ';';
281 #endif /*GAUCHE_WINDOWS*/
282
283 if (e == NULL || strlen(e) == 0) {
284 return SCM_NIL;
285 } else if (Scm_IsSugid()) {
286 /* don't trust env when setugid'd */
287 return SCM_NIL;
288 } else {
289 return Scm_StringSplitByChar(SCM_STRING(SCM_MAKE_STR_COPYING(e)),
290 delim);
291 }
292 }
293
add_list_item(ScmObj orig,ScmObj item,int afterp)294 static ScmObj add_list_item(ScmObj orig, ScmObj item, int afterp)
295 {
296 if (afterp) {
297 return Scm_Append2(orig, SCM_LIST1(item));
298 } else {
299 return Scm_Cons(item, orig);
300 }
301 }
302 #define ADD_LIST_ITEM(list, item, afterp) \
303 list = add_list_item(list, item, afterp)
304
305 /* Add CPATH to the current list of load path. The path is
306 * added before the current list, unless AFTERP is true.
307 * The existence of CPATH is not checked.
308 *
309 * Besides load paths, existence of directories CPATH/$ARCH and
310 * CPATH/../$ARCH is checked, where $ARCH is the system architecture
311 * signature, and if found, it is added to the dynload_path. If
312 * no such directory is found, CPATH itself is added to the dynload_path.
313 */
Scm_AddLoadPath(const char * cpath,int afterp)314 ScmObj Scm_AddLoadPath(const char *cpath, int afterp)
315 {
316 ScmObj spath = SCM_MAKE_STR_COPYING(cpath);
317 ScmStat statbuf;
318
319 /* check dynload path */
320 ScmObj dpath = Scm_StringAppendC(SCM_STRING(spath), "/", 1, 1);
321 dpath = Scm_StringAppendC(SCM_STRING(dpath), Scm_HostArchitecture(),-1,-1);
322 if (stat(Scm_GetStringConst(SCM_STRING(dpath)), &statbuf) < 0
323 || !S_ISDIR(statbuf.st_mode)) {
324 dpath = Scm_StringAppendC(SCM_STRING(spath), "/../", 4, 4);
325 dpath = Scm_StringAppendC(SCM_STRING(dpath), Scm_HostArchitecture(),-1,-1);
326 if (stat(Scm_GetStringConst(SCM_STRING(dpath)), &statbuf) < 0
327 || !S_ISDIR(statbuf.st_mode)) {
328 dpath = spath;
329 }
330 }
331
332 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.path_mutex);
333 ADD_LIST_ITEM(ldinfo.load_path_rec->value, spath, afterp);
334 ADD_LIST_ITEM(ldinfo.dynload_path_rec->value, dpath, afterp);
335 ScmObj r = ldinfo.load_path_rec->value;
336 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.path_mutex);
337
338 return r;
339 }
340
Scm_AddLoadPathHook(ScmObj proc,int afterp)341 void Scm_AddLoadPathHook(ScmObj proc, int afterp)
342 {
343 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.path_mutex);
344 ADD_LIST_ITEM(ldinfo.load_path_hooks_rec->value, proc, afterp);
345 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.path_mutex);
346 }
347
Scm_DeleteLoadPathHook(ScmObj proc)348 void Scm_DeleteLoadPathHook(ScmObj proc)
349 {
350 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.path_mutex);
351 /* we should use Scm_Delete, instead of Scm_DeleteX,
352 to avoid race with reader of the list */
353 ldinfo.load_path_hooks_rec->value
354 = Scm_Delete(proc, ldinfo.load_path_hooks_rec->value, SCM_CMP_EQ);
355 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.path_mutex);
356 }
357
358 /*------------------------------------------------------------------
359 * Dynamic linking
360 */
361
362 /* The API to load object file dynamically differ among platforms.
363 * We include the platform-dependent implementations (dl_*.c) that
364 * provides a common API:
365 *
366 * void *dl_open(const char *pathname)
367 * Dynamically loads the object file specified by PATHNAME,
368 * and returns its handle. On failure, returns NULL.
369 *
370 * PATHNAME is guaranteed to contain directory names, so this function
371 * doesn't need to look it up in the search paths.
372 * The caller also checks whether pathname is already loaded or not,
373 * so this function doesn't need to worry about duplicate loads.
374 * This function should have the semantics equivalent to the
375 * RTLD_NOW|RTLD_GLOBAL of dlopen().
376 *
377 * We don't call with NULL as PATHNAME; dlopen() returns the handle
378 * of the calling program itself in such a case, but we never need that
379 * behavior.
380 *
381 * ScmDynloadInitFn dl_sym(void *handle, const char *symbol)
382 * Finds the address of SYMBOL in the dl_openModule()-ed module
383 * HANDLE.
384 *
385 * void dl_close(void *handle)
386 * Closes the opened module. This can only be called when we couldn't
387 * find the initialization function in the module; once the initialization
388 * function is called, we don't have a safe way to remove the module.
389 *
390 * const char *dl_error(void)
391 * Returns the last error occurred on HANDLE in the dl_* function.
392 *
393 * Notes:
394 * - The caller must take care of mutex so that dl_ won't be called from
395 * more than one thread at a time, and no other thread calls
396 * dl_* functions between dl_open and dl_error (so that dl_open
397 * can store the error info in global variable).
398 *
399 * Since this API assumes the caller does a lot of work, the implementation
400 * should be much simpler than implementing fully dlopen()-compatible
401 * functions.
402 */
403
404 /* The implementation of dynamic loader is a bit complicated in the presence
405 of multiple threads and multiple initialization routines.
406
407 We keep ScmDLObj record for each DYNAMIC-LOADed files (keyed
408 by pathname including suffix) to track the state of loading. The thread
409 must lock the structure first to operate on the particluar DSO.
410
411 By default, a DSO has one initialization function (initfn) whose name
412 can be derived from DSO's basename (if DSO is /foo/bar/baz.so, the
413 initfn is Scm_Init_baz). DSO may have more than one initfn, if it is
414 made from multiple Scheme files via precompiler; in which case, each
415 initfn initializes a part of DSO corresponding to a Scheme module.
416 Each *.sci file contains dynamic-load form of the DSO with :init-function
417 keyword arguments.
418 */
419
420 typedef void (*ScmDynLoadInitFn)(void);
421
422 typedef struct dlobj_initfn_rec {
423 struct dlobj_initfn_rec *next; /* chain */
424 const char *name; /* name of initfn (always w/ leading '_') */
425 ScmDynLoadInitFn fn; /* function ptr */
426 int initialized; /* TRUE once fn returns */
427 } dlobj_initfn;
428
429 struct ScmDLObjRec {
430 SCM_HEADER;
431 ScmString *path; /* pathname for DSO, including suffix */
432 int loaded; /* TRUE if this DSO is already loaded.
433 It may need to be initialized, though.
434 Check initfns. */
435 void *handle; /* whatever dl_open returned */
436 ScmVM *loader; /* The VM that's holding the lock to operate
437 on this DLO. */
438 dlobj_initfn *initfns; /* list of initializer functions */
439 ScmInternalMutex mutex;
440 ScmInternalCond cv;
441 };
442
dlobj_print(ScmObj obj,ScmPort * sink,ScmWriteContext * mode SCM_UNUSED)443 static void dlobj_print(ScmObj obj, ScmPort *sink,
444 ScmWriteContext *mode SCM_UNUSED)
445 {
446 Scm_Printf(sink, "#<dlobj \"%s\">", SCM_DLOBJ(obj)->path);
447 }
448
449 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_DLObjClass, dlobj_print);
450
make_dlobj(ScmString * path)451 static ScmDLObj *make_dlobj(ScmString *path)
452 {
453 ScmDLObj *z = SCM_NEW(ScmDLObj);
454 SCM_SET_CLASS(z, &Scm_DLObjClass);
455 z->path = path;
456 z->loader = NULL;
457 z->loaded = FALSE;
458 z->initfns = NULL;
459 (void)SCM_INTERNAL_MUTEX_INIT(z->mutex);
460 (void)SCM_INTERNAL_COND_INIT(z->cv);
461 return z;
462 }
463
464 /* NB: we rely on dlcompat library for dlopen instead of using dl_darwin.c
465 for now; Boehm GC requires dlopen when compiled with pthread, so there's
466 not much point to avoid dlopen here. */
467 #if defined(HAVE_DLOPEN)
468 #include "dl_dlopen.c"
469 #elif defined(GAUCHE_WINDOWS)
470 #include "dl_win.c"
471 #else
472 #include "dl_dummy.c"
473 #endif
474
475 /* Find dlobj with path, creating one if there aren't, and returns it. */
find_dlobj(ScmObj path)476 static ScmDLObj *find_dlobj(ScmObj path)
477 {
478 ScmDLObj *z = NULL;
479
480 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.dso_mutex);
481 ScmObj p = Scm_HashTableRef(ldinfo.dso_table, path, SCM_FALSE);
482 if (SCM_DLOBJP(p)) {
483 z = SCM_DLOBJ(p);
484 } else {
485 z = make_dlobj(SCM_STRING(path));
486 Scm_HashTableSet(ldinfo.dso_table, path, SCM_OBJ(z), 0);
487 }
488 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.dso_mutex);
489 return z;
490 }
491
lock_dlobj(ScmDLObj * dlo)492 static void lock_dlobj(ScmDLObj *dlo)
493 {
494 ScmVM *vm = Scm_VM();
495 (void)SCM_INTERNAL_MUTEX_LOCK(dlo->mutex);
496 while (dlo->loader != vm) {
497 if (dlo->loader == NULL) break;
498 (void)SCM_INTERNAL_COND_WAIT(dlo->cv, dlo->mutex);
499 }
500 dlo->loader = vm;
501 (void)SCM_INTERNAL_MUTEX_UNLOCK(dlo->mutex);
502 }
503
unlock_dlobj(ScmDLObj * dlo)504 static void unlock_dlobj(ScmDLObj *dlo)
505 {
506 (void)SCM_INTERNAL_MUTEX_LOCK(dlo->mutex);
507 dlo->loader = NULL;
508 (void)SCM_INTERNAL_COND_BROADCAST(dlo->cv);
509 (void)SCM_INTERNAL_MUTEX_UNLOCK(dlo->mutex);
510 }
511
512 /* find dlobj_initfn from the given dlobj with name.
513 Assuming the caller holding the lock of OBJ. */
find_initfn(ScmDLObj * dlo,const char * name)514 static dlobj_initfn *find_initfn(ScmDLObj *dlo, const char *name)
515 {
516 dlobj_initfn *fns = dlo->initfns;
517 for (; fns != NULL; fns = fns->next) {
518 if (strcmp(name, fns->name) == 0) return fns;
519 }
520 fns = SCM_NEW(dlobj_initfn);
521 fns->name = name;
522 fns->fn = NULL;
523 fns->initialized = FALSE;
524 fns->next = dlo->initfns;
525 dlo->initfns = fns;
526 return fns;
527 }
528
529 /* Load the DSO. The caller holds the lock of dlobj. May throw an error;
530 the caller makes sure it releases the lock even in that case. */
load_dlo(ScmDLObj * dlo)531 static void load_dlo(ScmDLObj *dlo)
532 {
533 ScmVM *vm = Scm_VM();
534 if (SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_LOAD_VERBOSE)) {
535 int len = Scm_Length(PARAM_REF(vm, load_history));
536 SCM_PUTZ(";;", 2, SCM_CURERR);
537 while (len-- > 0) Scm_Putz(" ", 2, SCM_CURERR);
538 Scm_Printf(SCM_CURERR, "Dynamically Loading %A...\n", dlo->path);
539 }
540 dlo->handle = dl_open(Scm_GetStringConst(dlo->path));
541 if (dlo->handle == NULL) {
542 const char *err = dl_error();
543 if (err == NULL) {
544 Scm_Error("failed to link %A dynamically", dlo->path);
545 } else {
546 Scm_Error("failed to link %A dynamically: %s", dlo->path, err);
547 }
548 /*NOTREACHED*/
549 }
550 dlo->loaded = TRUE;
551 }
552
553 /* Call the DSO's initfn. The caller holds the lock of dlobj, and responsible
554 to release the lock even when this fn throws an error. */
call_initfn(ScmDLObj * dlo,const char * name)555 static void call_initfn(ScmDLObj *dlo, const char *name)
556 {
557 dlobj_initfn *ifn = find_initfn(dlo, name);
558
559 if (ifn->initialized) return;
560
561 if (!ifn->fn) {
562 /* locate initfn. Name always has '_'. Whether the actual
563 symbol dl_sym returns has '_' or not depends on the platform,
564 so we first try without '_', then '_'. */
565 ifn->fn = dl_sym(dlo->handle, name+1);
566 if (ifn->fn == NULL) {
567 ifn->fn = (void(*)(void))dl_sym(dlo->handle, name);
568 if (ifn->fn == NULL) {
569 dl_close(dlo->handle);
570 dlo->handle = NULL;
571 Scm_Error("dynamic linking of %A failed: "
572 "couldn't find initialization function %s",
573 dlo->path, name);
574 /*NOTREACHED*/
575 }
576 }
577 }
578
579 /* Call initialization function. note that there can be arbitrary
580 complex stuff done within func(), including evaluation of
581 Scheme procedures and/or calling dynamic-load for other
582 object. There's a chance that, with some contrived case,
583 func() can trigger the dynamic loading of the same file we're
584 loading right now. However, if the code follows the Gauche's
585 standard module structure, such circular dependency is detected
586 by Scm_Load, so we don't worry about it here. */
587 ifn->fn();
588 ifn->initialized = TRUE;
589 }
590
591 /* Experimental: Prelink feature---we allow the extension module to be
592 statically linked, and (dynamic-load DSONAME) merely calls initfn.
593 The application needs to call Scm_RegisterPrelinked to tell the system
594 which DSO is statically linked. We pretend that the named DSO is
595 already loaded from a pseudo pathname "@/DSONAME" (e.g. for
596 "gauche--collection", we use "@/gauche--collection".) */
597
598 /* Register DSONAME as prelinked. DSONAME shouldn't have system's suffix.
599 INITFNS is an array of function pointers, NULL terminated.
600 INITFN_NAMES should have prefixed with '_', for call_initfn() searches
601 names with '_' first. */
Scm_RegisterPrelinked(ScmString * dsoname,const char * initfn_names[],ScmDynLoadInitFn initfns[])602 void Scm_RegisterPrelinked(ScmString *dsoname,
603 const char *initfn_names[],
604 ScmDynLoadInitFn initfns[])
605 {
606 ScmObj path = Scm_StringAppend2(SCM_STRING(SCM_MAKE_STR_IMMUTABLE("@/")),
607 dsoname);
608 ScmDLObj *dlo = find_dlobj(path);
609 dlo->loaded = TRUE;
610
611 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.dso_mutex);
612 for (int i=0; initfns[i] && initfn_names[i]; i++) {
613 dlobj_initfn *ifn = find_initfn(dlo, initfn_names[i]);
614 SCM_ASSERT(ifn->fn == NULL);
615 ifn->fn = initfns[i];
616 }
617 ldinfo.dso_prelinked = Scm_Cons(SCM_OBJ(dsoname), ldinfo.dso_prelinked);
618 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.dso_mutex);
619 }
620
find_prelinked(ScmString * dsoname)621 static ScmObj find_prelinked(ScmString *dsoname)
622 {
623 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.dso_mutex);
624 /* in general it is dangerous to invoke equal?-comparison during lock,
625 but in this case we know they're string comparison and won't raise
626 an error. */
627 ScmObj z = Scm_Member(SCM_OBJ(dsoname), ldinfo.dso_prelinked, SCM_CMP_EQUAL);
628 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.dso_mutex);
629 if (!SCM_FALSEP(z)) {
630 return Scm_StringAppend2(SCM_STRING(SCM_MAKE_STR_IMMUTABLE("@/")),
631 dsoname);
632 } else {
633 return SCM_FALSE;
634 }
635 }
636
637 /* Dynamically load the specified object by DSONAME.
638 DSONAME must not contain the system's suffix (.so, for example).
639 The same name of DSO can be only loaded once.
640 A DSO may contain multiple initialization functions (initfns), in
641 which case each initfn is called at most once.
642 */
Scm_DynLoad(ScmString * dsoname,ScmObj initfn,u_long flags SCM_UNUSED)643 ScmObj Scm_DynLoad(ScmString *dsoname, ScmObj initfn,
644 u_long flags SCM_UNUSED /*reserved*/)
645 {
646 ScmObj dsopath = find_prelinked(dsoname);
647 if (SCM_FALSEP(dsopath)) {
648 static ScmObj find_load_file_proc = SCM_UNDEFINED;
649 SCM_BIND_PROC(find_load_file_proc, "find-load-file",
650 Scm_GaucheInternalModule());
651 ScmObj spath = Scm_ApplyRec3(find_load_file_proc,
652 SCM_OBJ(dsoname),
653 Scm_GetDynLoadPath(),
654 ldinfo.dso_suffixes);
655 if (!SCM_PAIRP(spath)) {
656 Scm_Error("can't find dlopen-able module %S", dsoname);
657 }
658 dsopath = SCM_CAR(spath);
659 SCM_ASSERT(SCM_STRINGP(dsopath));
660 }
661 static ScmObj get_initfn_name_proc = SCM_UNDEFINED;
662 SCM_BIND_PROC(get_initfn_name_proc, "%get-initfn-name",
663 Scm_GaucheInternalModule());
664 ScmObj s_initname = Scm_ApplyRec2(get_initfn_name_proc, initfn, dsopath);
665 const char *initname = Scm_GetStringConst(SCM_STRING(s_initname));
666 ScmDLObj *dlo = find_dlobj(dsopath);
667
668 /* Load the dlobj if necessary. */
669 lock_dlobj(dlo);
670 if (!dlo->loaded) {
671 SCM_UNWIND_PROTECT { load_dlo(dlo); }
672 SCM_WHEN_ERROR { unlock_dlobj(dlo); SCM_NEXT_HANDLER; }
673 SCM_END_PROTECT;
674 }
675
676 /* Now the dlo is loaded. We need to call initializer. */
677 SCM_ASSERT(dlo->loaded);
678
679 SCM_UNWIND_PROTECT { call_initfn(dlo, initname); }
680 SCM_WHEN_ERROR { unlock_dlobj(dlo); SCM_NEXT_HANDLER; }
681 SCM_END_PROTECT;
682
683 unlock_dlobj(dlo);
684 return SCM_TRUE;
685 }
686
687 /* Expose dlobj to Scheme world */
688
dlobj_path_get(ScmObj obj)689 static ScmObj dlobj_path_get(ScmObj obj)
690 {
691 return SCM_OBJ(SCM_DLOBJ(obj)->path);
692 }
693
dlobj_loaded_get(ScmObj obj)694 static ScmObj dlobj_loaded_get(ScmObj obj)
695 {
696 return SCM_MAKE_BOOL(SCM_DLOBJ(obj)->loaded);
697 }
698
dlobj_initfns_get(ScmObj obj)699 static ScmObj dlobj_initfns_get(ScmObj obj)
700 {
701 ScmObj h = SCM_NIL;
702 ScmObj t = SCM_NIL;
703 lock_dlobj(SCM_DLOBJ(obj));
704 dlobj_initfn *ifn = SCM_DLOBJ(obj)->initfns;
705 for (;ifn != NULL; ifn = ifn->next) {
706 ScmObj p = Scm_Cons(SCM_MAKE_STR_IMMUTABLE(ifn->name),
707 SCM_MAKE_BOOL(ifn->initialized));
708 SCM_APPEND1(h, t, p);
709 }
710 unlock_dlobj(SCM_DLOBJ(obj));
711 return h;
712 }
713
714 static ScmClassStaticSlotSpec dlobj_slots[] = {
715 SCM_CLASS_SLOT_SPEC("path", dlobj_path_get, NULL),
716 SCM_CLASS_SLOT_SPEC("loaded?", dlobj_loaded_get, NULL),
717 SCM_CLASS_SLOT_SPEC("init-functions", dlobj_initfns_get, NULL),
718 SCM_CLASS_SLOT_SPEC_END()
719 };
720
Scm_DLObjs()721 ScmObj Scm_DLObjs()
722 {
723 ScmObj z = SCM_NIL;
724 ScmHashIter iter;
725 ScmDictEntry *e;
726 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.dso_mutex);
727 Scm_HashIterInit(&iter, SCM_HASH_TABLE_CORE(ldinfo.dso_table));
728 while ((e = Scm_HashIterNext(&iter)) != NULL) {
729 z = Scm_Cons(SCM_OBJ(SCM_DICT_VALUE(e)), z);
730 }
731 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.dso_mutex);
732 return z;
733 }
734
735 /*------------------------------------------------------------------
736 * Require and provide
737 */
738
739 /* STk's require takes a string. SLIB's require takes a symbol.
740 For now, I allow only a string. */
741 /* Note that require and provide is recognized at compile time. */
742
743 static int do_require(ScmObj, int, ScmModule *, ScmLoadPacket *);
744
745 /* [Preventing Race Condition]
746 *
747 * Besides the list of provided features (ldinfo.provided), the
748 * system keeps two kind of global assoc list for transient information.
749 *
750 * ldinfo.providing keeps a list of (<feature> <thread> <provided> ...),
751 * where <thread> is currently loading a file for <feature>.
752 * ldinfo.waiting keeps a list of (<thread> . <feature>), where
753 * <thread> is waiting for <feature> to be provided.
754 * (The <provided> list is pushed by 'provide' while loading <feature>.
755 * It is used for autprovide feature. See below).
756 *
757 * Scm_Require first checks ldinfo.provided list; if the feature is
758 * already provided, no problem; just return.
759 * If not, ldinfo.providing is searched. If the feature is being provided
760 * by some other thread, the calling thread pushes itself onto
761 * ldinfo.waiting list and waits for the feature to be provided.
762 *
763 * There may be a case that the feature dependency forms a loop because
764 * of a bug. An error should be signaled in such a case, rather than going
765 * to deadlock. So, when the calling thread finds the required feature
766 * is in the ldinfo.providing alist, it checks the waiting chain of
767 * features, and no threads are waiting for a feature being provided by
768 * the calling thread.
769 *
770 * When the above checks are all false, the calling thread is responsible
771 * to load the required feature. It pushes the feature and itself
772 * onto the providing list and start loading the file.
773 *
774 * [Autoprovide Feature]
775 *
776 * When a file is loaded via 'require', it almost always provides the
777 * required feature. Thus we allow the file to omit the 'provide' form.
778 * That is, if a file X.scm is loaded because of (require "X"), and
779 * there's no 'provide' form in X.scm, the feature "X" is automatically
780 * provided upon a successful loading of X.scm.
781 *
782 * If a 'provide' form appears in X.scm, the autoprovide feature is
783 * turned off. It is allowed that X.scm provides features other than
784 * "X". As a special case, (provide #f) causes the autoprovide feature
785 * to be turned of without providing any feature.
786 *
787 * To track what is provided, the 'provide' form pushes its argument
788 * to the entry of 'providing' list whose thread matches the calling
789 * thread. (It is possible that there's more than one entry in the
790 * 'providing' list, for a required file may call another require form.
791 * The entry is always pushed at the beginning of the providing list,
792 * we know that the first matching entry is the current one.)
793 */
794
795 /* NB: It has never been explicit, but 'require' and 'extend' are expected to
796 work as if we load the module into #<module gauche>. Those forms only loads
797 the file once, so it doesn't make much sense to allow it to load into
798 different modules for each time, since you never know whether the file
799 is loaded at this time or it has already been loaded. With the same
800 reason, it doesn't make much sense to use the current module.
801
802 On 0.9.4 we always set the base module to #<module gauche> to do require,
803 so that we can guarantee the forms like define-module or define-library
804 to be visible from the loaded module (if we use the caller's current
805 module it is not guaranteed.) However, it had an unexpected side
806 effect: If the loaded module inserts toplevel definitions or imports
807 other modules without first setting its own module, it actually
808 modifies #<module gauche>.
809
810 As of 0.9.5, we use an immutable module #<module gauche.require-base>
811 as the base module. Since it is immutable, any toplevel definitions
812 or imports without first switching modules are rejected.
813 */
Scm_Require(ScmObj feature,int flags,ScmLoadPacket * packet)814 int Scm_Require(ScmObj feature, int flags, ScmLoadPacket *packet)
815 {
816 return do_require(feature, flags, Scm__RequireBaseModule(), packet);
817 }
818
do_require(ScmObj feature,int flags,ScmModule * base_mod,ScmLoadPacket * packet)819 int do_require(ScmObj feature, int flags, ScmModule *base_mod,
820 ScmLoadPacket *packet)
821 {
822 ScmVM *vm = Scm_VM();
823 ScmObj provided;
824 int loop = FALSE;
825
826 load_packet_prepare(packet);
827 if (!SCM_STRINGP(feature)) {
828 ScmObj e = Scm_MakeError(Scm_Sprintf("require: string expected, but got %S\n", feature));
829 if (flags&SCM_LOAD_PROPAGATE_ERROR) Scm_Raise(e, 0);
830 else {
831 if (packet) packet->exception = e;
832 return -1;
833 }
834 }
835
836 /* Check provided, providing and waiting list. See the comment above. */
837 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.prov_mutex);
838 for (;;) {
839 provided = Scm_Member(feature, ldinfo.provided, SCM_CMP_EQUAL);
840 if (!SCM_FALSEP(provided)) break;
841 ScmObj providing = Scm_Assoc(feature, ldinfo.providing, SCM_CMP_EQUAL);
842 if (SCM_FALSEP(providing)) break;
843
844 /* Checks for dependencies */
845 ScmObj p = providing;
846 SCM_ASSERT(SCM_PAIRP(p) && SCM_PAIRP(SCM_CDR(p)));
847 if (SCM_CADR(p) == SCM_OBJ(vm)) { loop = TRUE; break; }
848
849 for (;;) {
850 ScmObj q = Scm_Assq(SCM_CDR(p), ldinfo.waiting);
851 if (SCM_FALSEP(q)) break;
852 SCM_ASSERT(SCM_PAIRP(q));
853 p = Scm_Assoc(SCM_CDR(q), ldinfo.providing, SCM_CMP_EQUAL);
854 SCM_ASSERT(SCM_PAIRP(p) && SCM_PAIRP(SCM_CDR(p)));
855 if (SCM_CADR(p) == SCM_OBJ(vm)) { loop = TRUE; break; }
856 }
857 if (loop) break;
858 ldinfo.waiting = Scm_Acons(SCM_OBJ(vm), feature, ldinfo.waiting);
859 (void)SCM_INTERNAL_COND_WAIT(ldinfo.prov_cv, ldinfo.prov_mutex);
860 ldinfo.waiting = Scm_AssocDeleteX(SCM_OBJ(vm), ldinfo.waiting, SCM_CMP_EQ);
861 }
862 if (!loop && SCM_FALSEP(provided)) {
863 ldinfo.providing =
864 Scm_Acons(feature, SCM_LIST1(SCM_OBJ(vm)), ldinfo.providing);
865 }
866 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.prov_mutex);
867
868 if (loop) {
869 ScmObj e = Scm_MakeError(Scm_Sprintf("a loop is detected in the require dependency involving feature %S", feature));
870 if (flags&SCM_LOAD_PROPAGATE_ERROR) Scm_Raise(e, 0);
871 else {
872 if (packet) packet->exception = e;
873 return -1;
874 }
875 }
876
877 if (!SCM_FALSEP(provided)) return 0; /* no work to do */
878 /* Make sure to load the file into base_mod. We don't need UNWIND_PROTECT
879 here, since errors are caught in Scm_Load. */
880 ScmLoadPacket xresult;
881 ScmModule *prev_mod = vm->module;
882 vm->module = base_mod;
883 int r = Scm_Load(Scm_GetStringConst(SCM_STRING(feature)), 0, &xresult);
884 vm->module = prev_mod;
885 if (packet) packet->exception = xresult.exception;
886
887 if (r < 0) {
888 /* Load failed */
889 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.prov_mutex);
890 ldinfo.providing = Scm_AssocDeleteX(feature, ldinfo.providing, SCM_CMP_EQUAL);
891 (void)SCM_INTERNAL_COND_BROADCAST(ldinfo.prov_cv);
892 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.prov_mutex);
893 if (flags&SCM_LOAD_PROPAGATE_ERROR) Scm_Raise(xresult.exception, 0);
894 else return -1;
895 }
896
897 /* Success */
898 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.prov_mutex);
899 ScmObj p = Scm_Assoc(feature, ldinfo.providing, SCM_CMP_EQUAL);
900 ldinfo.providing = Scm_AssocDeleteX(feature, ldinfo.providing, SCM_CMP_EQUAL);
901 /* `Autoprovide' feature */
902 if (SCM_NULLP(SCM_CDDR(p))
903 && SCM_FALSEP(Scm_Member(feature, ldinfo.provided, SCM_CMP_EQUAL))) {
904 ldinfo.provided = Scm_Cons(feature, ldinfo.provided);
905 }
906 (void)SCM_INTERNAL_COND_BROADCAST(ldinfo.prov_cv);
907 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.prov_mutex);
908 if (packet) packet->loaded = TRUE;
909 return 0;
910 }
911
Scm_Provide(ScmObj feature)912 ScmObj Scm_Provide(ScmObj feature)
913 {
914 ScmVM *self = Scm_VM();
915
916 if (!SCM_STRINGP(feature)&&!SCM_FALSEP(feature)) {
917 SCM_TYPE_ERROR(feature, "string");
918 }
919 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.prov_mutex);
920 if (SCM_STRINGP(feature)
921 && SCM_FALSEP(Scm_Member(feature, ldinfo.provided, SCM_CMP_EQUAL))) {
922 ldinfo.provided = Scm_Cons(feature, ldinfo.provided);
923 }
924 ScmObj cp;
925 SCM_FOR_EACH(cp, ldinfo.providing) {
926 if (SCM_CADR(SCM_CAR(cp)) == SCM_OBJ(self)) {
927 SCM_SET_CDR_UNCHECKED(SCM_CDR(SCM_CAR(cp)), SCM_LIST1(feature));
928 break;
929 }
930 }
931 (void)SCM_INTERNAL_COND_SIGNAL(ldinfo.prov_cv);
932 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.prov_mutex);
933 return feature;
934 }
935
Scm_ProvidedP(ScmObj feature)936 int Scm_ProvidedP(ScmObj feature)
937 {
938 (void)SCM_INTERNAL_MUTEX_LOCK(ldinfo.prov_mutex);
939 int r = !SCM_FALSEP(Scm_Member(feature, ldinfo.provided, SCM_CMP_EQUAL));
940 (void)SCM_INTERNAL_MUTEX_UNLOCK(ldinfo.prov_mutex);
941 return r;
942 }
943
944 /*------------------------------------------------------------------
945 * Autoload
946 */
947
autoload_print(ScmObj obj,ScmPort * out,ScmWriteContext * ctx SCM_UNUSED)948 static void autoload_print(ScmObj obj, ScmPort *out,
949 ScmWriteContext *ctx SCM_UNUSED)
950 {
951 Scm_Printf(out, "#<autoload %A::%A (%A)>",
952 SCM_AUTOLOAD(obj)->module->name,
953 SCM_AUTOLOAD(obj)->name, SCM_AUTOLOAD(obj)->path);
954 }
955
956 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_AutoloadClass, autoload_print);
957
Scm_MakeAutoload(ScmModule * where,ScmSymbol * name,ScmString * path,ScmSymbol * import_from)958 ScmObj Scm_MakeAutoload(ScmModule *where,
959 ScmSymbol *name,
960 ScmString *path,
961 ScmSymbol *import_from)
962 {
963 ScmAutoload *adata = SCM_NEW(ScmAutoload);
964 SCM_SET_CLASS(adata, SCM_CLASS_AUTOLOAD);
965 adata->name = name;
966 adata->module = where;
967 adata->path = path;
968 adata->import_from = import_from;
969 adata->loaded = FALSE;
970 adata->value = SCM_UNBOUND;
971 (void)SCM_INTERNAL_MUTEX_INIT(adata->mutex);
972 (void)SCM_INTERNAL_COND_INIT(adata->cv);
973 adata->locker = NULL;
974 return SCM_OBJ(adata);
975 }
976
Scm_DefineAutoload(ScmModule * where,ScmObj file_or_module,ScmObj list)977 void Scm_DefineAutoload(ScmModule *where,
978 ScmObj file_or_module,
979 ScmObj list)
980 {
981 ScmString *path = NULL;
982 ScmSymbol *import_from = NULL;
983
984 if (SCM_STRINGP(file_or_module)) {
985 path = SCM_STRING(file_or_module);
986 } else if (SCM_SYMBOLP(file_or_module)) {
987 import_from = SCM_SYMBOL(file_or_module);
988 path = SCM_STRING(Scm_ModuleNameToPath(import_from));
989 } else {
990 Scm_Error("autoload: string or symbol required, but got %S",
991 file_or_module);
992 }
993 ScmObj ep;
994 SCM_FOR_EACH(ep, list) {
995 ScmObj entry = SCM_CAR(ep);
996 if (SCM_SYMBOLP(entry)) {
997 Scm_Define(where, SCM_SYMBOL(entry),
998 Scm_MakeAutoload(where, SCM_SYMBOL(entry),
999 path, import_from));
1000 } else if (SCM_PAIRP(entry)
1001 && SCM_EQ(key_macro, SCM_CAR(entry))
1002 && SCM_PAIRP(SCM_CDR(entry))
1003 && SCM_SYMBOLP(SCM_CADR(entry))) {
1004 ScmSymbol *sym = SCM_SYMBOL(SCM_CADR(entry));
1005 ScmObj autoload = Scm_MakeAutoload(where, sym, path, import_from);
1006 Scm_Define(where, sym,
1007 Scm_MakeMacroAutoload(sym, SCM_AUTOLOAD(autoload)));
1008 } else {
1009 Scm_Error("autoload: bad autoload symbol entry: %S", entry);
1010 }
1011 }
1012 }
1013
1014
Scm_ResolveAutoload(ScmAutoload * adata,int flags SCM_UNUSED)1015 ScmObj Scm_ResolveAutoload(ScmAutoload *adata, int flags SCM_UNUSED)
1016 {
1017 int circular = FALSE;
1018 ScmVM *vm = Scm_VM();
1019
1020 /* shortcut in case if somebody else already did the job. */
1021 if (adata->loaded) return adata->value;
1022
1023 /* check to see if this autoload is recursive. if so, we just return
1024 SCM_UNBOUND and let the caller handle the issue (NB: it isn't
1025 necessarily an error. For example, define-method searches if
1026 a generic function of the same name is already defined; if the
1027 name is set autoload and define-method is in the file that's being
1028 autoloaded, define-method finds the name is an autoload that points
1029 the currently autoloaded file.)
1030 we have to be careful to exclude the case that when one thread is
1031 resolving autoload another thread enters here and sees this autoload
1032 is already being resolved.
1033 */
1034 if ((adata->locker == NULL || adata->locker == vm)
1035 && !SCM_FALSEP(Scm_Assoc(SCM_OBJ(adata->path),
1036 ldinfo.providing,
1037 SCM_CMP_EQUAL))) {
1038 return SCM_UNBOUND;
1039 }
1040
1041 /* obtain the lock to load this autoload */
1042 (void)SCM_INTERNAL_MUTEX_LOCK(adata->mutex);
1043 do {
1044 if (adata->loaded) break;
1045 if (adata->locker == NULL) {
1046 adata->locker = vm;
1047 } else if (adata->locker == vm) {
1048 /* bad circular dependency */
1049 circular = TRUE;
1050 } else if (adata->locker->state == SCM_VM_TERMINATED) {
1051 /* the loading thread have died prematurely.
1052 let's take over the task. */
1053 adata->locker = vm;
1054 } else {
1055 (void)SCM_INTERNAL_COND_WAIT(adata->cv, adata->mutex);
1056 continue;
1057 }
1058 } while (0);
1059 SCM_INTERNAL_MUTEX_UNLOCK(adata->mutex);
1060 if (adata->loaded) {
1061 /* ok, somebody did the work for me. just use the result. */
1062 return adata->value;
1063 }
1064
1065 if (circular) {
1066 /* Since we have already checked recursive loading, it isn't normal
1067 if we reach here. Right now I have no idea how this happens, but
1068 just in case we raise an error. */
1069 adata->locker = NULL;
1070 SCM_INTERNAL_COND_BROADCAST(adata->cv);
1071 Scm_Error("Attempted to trigger the same autoload %S#%S recursively. Maybe circular autoload dependency?",
1072 adata->module, adata->name);
1073 }
1074
1075 SCM_UNWIND_PROTECT {
1076 do_require(SCM_OBJ(adata->path), SCM_LOAD_PROPAGATE_ERROR,
1077 adata->module, NULL);
1078
1079 if (adata->import_from) {
1080 /* autoloaded file defines import_from module. we need to
1081 import the binding individually. */
1082 ScmModule *m = Scm_FindModule(adata->import_from,
1083 SCM_FIND_MODULE_QUIET);
1084 if (m == NULL) {
1085 Scm_Error("Trying to autoload module %S from file %S, but the file doesn't define such a module",
1086 adata->import_from, adata->path);
1087 }
1088 ScmGloc *f = Scm_FindBinding(SCM_MODULE(m), adata->name, 0);
1089 ScmGloc *g = Scm_FindBinding(adata->module, adata->name, 0);
1090 SCM_ASSERT(f != NULL);
1091 SCM_ASSERT(g != NULL);
1092 adata->value = SCM_GLOC_GET(f);
1093 if (SCM_UNBOUNDP(adata->value) || SCM_AUTOLOADP(adata->value)) {
1094 Scm_Error("Autoloaded symbol %S is not defined in the module %S",
1095 adata->name, adata->import_from);
1096 }
1097 SCM_GLOC_SET(g, adata->value);
1098 } else {
1099 /* Normal import. The binding must have been inserted to
1100 adata->module */
1101 ScmGloc *g = Scm_FindBinding(adata->module, adata->name, 0);
1102 SCM_ASSERT(g != NULL);
1103 adata->value = SCM_GLOC_GET(g);
1104 if (SCM_UNBOUNDP(adata->value) || SCM_AUTOLOADP(adata->value)) {
1105 Scm_Error("Autoloaded symbol %S is not defined in the file %S",
1106 adata->name, adata->path);
1107 }
1108 }
1109 } SCM_WHEN_ERROR {
1110 adata->locker = NULL;
1111 SCM_INTERNAL_COND_BROADCAST(adata->cv);
1112 SCM_NEXT_HANDLER;
1113 } SCM_END_PROTECT;
1114
1115 adata->loaded = TRUE;
1116 adata->locker = NULL;
1117 SCM_INTERNAL_COND_BROADCAST(adata->cv);
1118 return adata->value;
1119 }
1120
1121 /*------------------------------------------------------------------
1122 * Dynamic parameter access
1123 */
Scm_CurrentLoadHistory()1124 ScmObj Scm_CurrentLoadHistory() { return PARAM_REF(Scm_VM(), load_history); }
Scm_CurrentLoadNext()1125 ScmObj Scm_CurrentLoadNext() { return PARAM_REF(Scm_VM(), load_next); }
Scm_CurrentLoadPort()1126 ScmObj Scm_CurrentLoadPort() { return PARAM_REF(Scm_VM(), load_port); }
1127
1128 /*------------------------------------------------------------------
1129 * Compatibility stuff
1130 */
1131
1132 #if GAUCHE_API_VERSION < 1000
1133 /* TRANSIENT: Pre-0.9 Compatibility routine. Kept for the binary compatibility.
1134 Will be removed on 1.0 */
Scm__LoadFromPortCompat(ScmPort * port,int flags)1135 void Scm__LoadFromPortCompat(ScmPort *port, int flags)
1136 {
1137 Scm_LoadFromPort(port, flags|SCM_LOAD_PROPAGATE_ERROR, NULL);
1138 }
1139
1140 /* TRANSIENT: Pre-0.9 Compatibility routine. Kept for the binary compatibility.
1141 Will be removed on 1.0 */
Scm__LoadCompat(const char * file,int flags)1142 int Scm__LoadCompat(const char *file, int flags)
1143 {
1144 return (0 == Scm_Load(file, flags|SCM_LOAD_PROPAGATE_ERROR, NULL));
1145 }
1146
1147 /* TRANSIENT: Pre-0.9 Compatibility routine. Kept for the binary compatibility.
1148 Will be removed on 1.0 */
Scm__RequireCompat(ScmObj feature)1149 ScmObj Scm__RequireCompat(ScmObj feature)
1150 {
1151 Scm_Require(feature, SCM_LOAD_PROPAGATE_ERROR, NULL);
1152 return SCM_TRUE;
1153 }
1154
1155 /* TRANSIENT: This is entirely moved to Scheme (libeval.scm). The entry is
1156 kept only for the binary compatibility. */
Scm_VMLoadFromPort(ScmPort * port SCM_UNUSED,ScmObj next_paths SCM_UNUSED,ScmObj env SCM_UNUSED,int flags SCM_UNUSED)1157 ScmObj Scm_VMLoadFromPort(ScmPort *port SCM_UNUSED,
1158 ScmObj next_paths SCM_UNUSED,
1159 ScmObj env SCM_UNUSED,
1160 int flags SCM_UNUSED)
1161 {
1162 Scm_Error("[internal] Scm_VMLoadFromPort() is obsoleted; call load-from-port Scheme procedure.");
1163 return SCM_UNDEFINED;
1164 }
1165
1166 /* TRANSIENT: Kept for the binary compatibility; the feature
1167 is in libeval.scm now. */
Scm__RecordLoadStart(ScmObj load_file_path SCM_UNUSED)1168 void Scm__RecordLoadStart(ScmObj load_file_path SCM_UNUSED)
1169 {
1170 }
1171
1172 /* TRANSIENT: Kept for the binary compatibility; not used anymore. */
Scm_LoadMainScript()1173 ScmObj Scm_LoadMainScript()
1174 {
1175 return SCM_UNDEFINED;
1176 }
1177 #endif /*GAUCHE_API_VERSION < 1000*/
1178
1179
1180 /*------------------------------------------------------------------
1181 * Initialization
1182 */
1183
Scm__InitLoad(void)1184 void Scm__InitLoad(void)
1185 {
1186 ScmModule *m = Scm_GaucheModule();
1187 ScmObj t;
1188
1189 ScmObj init_load_path = t = SCM_NIL;
1190 SCM_APPEND(init_load_path, t, break_env_paths("GAUCHE_LOAD_PATH"));
1191 SCM_APPEND1(init_load_path, t, Scm_SiteLibraryDirectory());
1192 SCM_APPEND1(init_load_path, t, Scm_LibraryDirectory());
1193
1194 ScmObj init_dynload_path = t = SCM_NIL;
1195 SCM_APPEND(init_dynload_path, t, break_env_paths("GAUCHE_DYNLOAD_PATH"));
1196 SCM_APPEND1(init_dynload_path, t, Scm_SiteArchitectureDirectory());
1197 SCM_APPEND1(init_dynload_path, t, Scm_ArchitectureDirectory());
1198
1199 ScmObj init_load_suffixes = t = SCM_NIL;
1200 SCM_APPEND1(init_load_suffixes, t, SCM_MAKE_STR(".sld")); /* R7RS library */
1201 SCM_APPEND1(init_load_suffixes, t, SCM_MAKE_STR(".sci"));
1202 SCM_APPEND1(init_load_suffixes, t, SCM_MAKE_STR(".scm"));
1203
1204 (void)SCM_INTERNAL_MUTEX_INIT(ldinfo.path_mutex);
1205 (void)SCM_INTERNAL_MUTEX_INIT(ldinfo.prov_mutex);
1206 (void)SCM_INTERNAL_COND_INIT(ldinfo.prov_cv);
1207 (void)SCM_INTERNAL_MUTEX_INIT(ldinfo.dso_mutex);
1208
1209 key_error_if_not_found = SCM_MAKE_KEYWORD("error-if-not-found");
1210 key_macro = SCM_MAKE_KEYWORD("macro");
1211 key_ignore_coding = SCM_MAKE_KEYWORD("ignore-coding");
1212 key_paths = SCM_MAKE_KEYWORD("paths");
1213 key_environment = SCM_MAKE_KEYWORD("environment");
1214 key_main_script = SCM_MAKE_KEYWORD("main-script");
1215
1216 Scm_InitStaticClass(SCM_CLASS_DLOBJ, "<dlobj>",
1217 m, dlobj_slots, 0);
1218
1219 #define DEF(rec, sym, val) \
1220 rec = SCM_GLOC(Scm_Define(m, SCM_SYMBOL(sym), val))
1221
1222 DEF(ldinfo.load_path_rec, SCM_SYM_LOAD_PATH, init_load_path);
1223 DEF(ldinfo.dynload_path_rec, SCM_SYM_DYNAMIC_LOAD_PATH, init_dynload_path);
1224 DEF(ldinfo.load_suffixes_rec, SCM_SYM_LOAD_SUFFIXES, init_load_suffixes);
1225 DEF(ldinfo.load_path_hooks_rec, SCM_SYM_LOAD_PATH_HOOKS, SCM_NIL);
1226
1227 /* NB: Some modules are built-in. We'll register them to the
1228 provided list, in libomega.scm. */
1229 ldinfo.provided = SCM_NIL;
1230 ldinfo.providing = SCM_NIL;
1231 ldinfo.waiting = SCM_NIL;
1232 ldinfo.dso_suffixes = SCM_LIST2(SCM_MAKE_STR(".la"),
1233 SCM_MAKE_STR("." SHLIB_SO_SUFFIX));
1234 ldinfo.dso_table = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_STRING,0));
1235 ldinfo.dso_prelinked = SCM_NIL;
1236
1237 #define PARAM_INIT(var, name, val) ldinfo.var = Scm_BindPrimitiveParameter(m, name, val, 0)
1238 PARAM_INIT(load_history, "current-load-history", SCM_NIL);
1239 PARAM_INIT(load_next, "current-load-next", SCM_NIL);
1240 PARAM_INIT(load_port, "current-load-port", SCM_FALSE);
1241 }
1242