1 /* library.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #include <sagittarius/config.h>
31 #ifndef __GNUC__
32 # ifdef HAVE_ALLOCA_H
33 # include <alloca.h>
34 # else
35 # ifdef _AIX
36 #pragma alloca
37 # else
38 # ifndef alloca /* predefined by HP cc +Olibcalls */
39 char *alloca ();
40 # endif
41 # endif
42 # endif
43 #else
44 # ifdef HAVE_ALLOCA_H
45 # include <alloca.h>
46 # endif
47 # ifdef HAVE_MALLOC_H
48 /* MinGW helds alloca() in "malloc.h" instead of "alloca.h" */
49 # include <malloc.h>
50 # endif
51 #endif
52
53 /* To secure the cache file between processes */
54 #ifdef HAVE_SEMAPHORE_H
55 /* if the platform have semaphore.h then it must have the rest 2 files. */
56 # include <fcntl.h>
57 # include <sys/stat.h>
58 # include <semaphore.h>
59 #endif
60
61 #include <ctype.h>
62 #define LIBSAGITTARIUS_BODY
63 #include "sagittarius/private/library.h"
64 #include "sagittarius/private/core.h"
65 #include "sagittarius/private/codec.h"
66 #include "sagittarius/private/transcoder.h"
67 #include "sagittarius/private/pair.h"
68 #include "sagittarius/private/file.h"
69 #include "sagittarius/private/hashtable.h"
70 #include "sagittarius/private/string.h"
71 #include "sagittarius/private/keyword.h"
72 #include "sagittarius/private/number.h"
73 #include "sagittarius/private/symbol.h"
74 #include "sagittarius/private/writer.h"
75 #include "sagittarius/private/error.h"
76 #include "sagittarius/private/vm.h"
77 #include "sagittarius/private/port.h"
78 #include "sagittarius/private/load.h"
79 #include "sagittarius/private/system.h"
80 #include "sagittarius/private/gloc.h"
81 #include "sagittarius/private/compare.h"
82 #include "sagittarius/private/thread.h"
83 #include "sagittarius/private/cache.h"
84 #include "sagittarius/private/reader.h"
85 #include "sagittarius/private/unicode.h"
86 #include "sagittarius/private/identifier.h"
87 #include "sagittarius/private/builtin-keywords.h"
88 #include "sagittarius/private/builtin-symbols.h"
89
library_print(SgObject obj,SgPort * port,SgWriteContext * ctx)90 static void library_print(SgObject obj, SgPort *port, SgWriteContext *ctx)
91 {
92 SgLibrary *lib = obj;
93 Sg_Putuz(port, UC("#<library "));
94 Sg_Write(lib->name, port, SG_WRITE_DISPLAY);
95 Sg_Putc(port, '>');
96 }
97
98 SG_DEFINE_BUILTIN_CLASS_SIMPLE(Sg_LibraryClass, library_print);
99
make_library()100 static SgLibrary* make_library()
101 {
102 SgLibrary *z = SG_NEW(SgLibrary);
103 SG_SET_CLASS(z, SG_CLASS_LIBRARY);
104 z->table = Sg_MakeHashTableSimple(SG_HASH_EQ, 1024);
105 z->imported = SG_NIL;
106 z->exported = SG_FALSE;
107 z->defined = SG_NIL;
108 z->version = SG_NIL;
109 z->parents = SG_NIL;
110 z->reader = SG_FALSE;
111 z->holder = SG_FALSE;
112 SG_LIBRARY_GENERICS(z) = SG_NIL;
113 SG_LIBRARY_MUTABLEP(z) = FALSE;
114 Sg_InitMutex(&z->lock, FALSE);
115 return z;
116 }
117
118 /* return library id and version pair
119 cf ((lib name) . (1 2))
120 */
check_version_reference(SgObject name,SgObject o)121 static void check_version_reference(SgObject name, SgObject o)
122 {
123 SG_FOR_EACH(o, o) {
124 SgObject v = SG_CAR(o);
125 if (!(SG_EXACT_INTP(v) && !Sg_NegativeP(v)) &&
126 /* version symbols */
127 !(SG_EQ(v, SG_SYMBOL_LESS_EQUAL) ||
128 SG_EQ(v, SG_SYMBOL_GREATER_EQUAL) ||
129 SG_EQ(v, SG_SYMBOL_OR) ||
130 SG_EQ(v, SG_SYMBOL_AND) ||
131 SG_EQ(v, SG_SYMBOL_NOT))) {
132 if (SG_PAIRP(v)) {
133 /* check recursively */
134 check_version_reference(name, v);
135 } else {
136 Sg_Error(UC("malformed library version %S"), name);
137 }
138 }
139 }
140 if (!SG_NULLP(o)) {
141 Sg_Error(UC("malformed library version %S"), name);
142 }
143 }
144
library_name_to_id_version(SgObject name)145 static SgObject library_name_to_id_version(SgObject name)
146 {
147 SgObject h = SG_NIL, t = SG_NIL, cp;
148 if (!SG_NULLP(name) && SG_PAIRP(name)) {
149 long len = Sg_Length(name);
150 if (len >= 0) {
151 SG_FOR_EACH(cp, name) {
152 SgObject o = SG_CAR(cp);
153 if (SG_SYMBOLP(o) || SG_KEYWORDP(o)) {
154 SG_APPEND1(h, t, o);
155 } else if (SG_IDENTIFIERP(o)) {
156 SG_APPEND1(h, t, SG_IDENTIFIER_NAME(o));
157 } else if (SG_EXACT_INTP(o)) {
158 /* R7RS allow unsigned exact integer as a library name */
159 if (Sg_Sign(o) < 0) {
160 Sg_Error(UC("malformed library name %S"), name);
161 }
162 SG_APPEND1(h, t, o);
163 } else if (SG_LISTP(o) && SG_NULLP(SG_CDR(cp))) {
164 check_version_reference(name, o);
165 return Sg_Cons(h, o);
166 } else {
167 Sg_Error(UC("malformed library name %S"), name);
168 }
169 }
170 /* no version number */
171 return Sg_Cons(h, SG_NIL);
172 }
173 /* fall through */
174 } else if (SG_SYMBOLP(name)) {
175 /* We may get library with version such as |(rnrs (6))|.
176 In this case we need to create (rnrs) library not (rnrs (6)).
177 So we need to do some trick here
178 */
179 SgString *s = SG_SYMBOL_NAME(name);
180 long len = SG_STRING_SIZE(s);
181 if (SG_STRING_VALUE_AT(s, len-1) == ')' &&
182 SG_STRING_VALUE_AT(s, len-2) == ')') {
183 /* ok we need to strip version number.
184 for now, we do rather stupid way.*/
185 SgStringPort sp;
186 SgObject in = Sg_InitStringInputPort(&sp, s, 0, len);
187 return library_name_to_id_version(Sg_Read(in, FALSE));
188 }
189 /* trust... */
190 return Sg_Cons(name, SG_NIL);
191 }
192 Sg_Error(UC("malformed library name %S"), name);
193 return SG_UNDEF; /* dummy */
194 }
195
convert_name_to_symbol(SgObject name)196 static SgSymbol* convert_name_to_symbol(SgObject name)
197 {
198 if (SG_STRINGP(name)) return Sg_Intern(name);
199 else if (SG_SYMBOLP(name)) return SG_SYMBOL(name);
200 else if (SG_PAIRP(name)) return Sg_Intern(Sg_Sprintf(UC("%L"), name));
201 else Sg_Error(UC("invalid library name %S"), name);
202 return SG_UNDEF; /* dummy */
203 }
204
205 /*
206 All libraries are stored here.
207 */
208 #define LIGHT_WEIGHT_LOCK 1
209 static struct
210 {
211 SgHashTable *libraries;
212 #ifdef LIGHT_WEIGHT_LOCK
213 SgVM *owner;
214 int count;
215 #endif
216 SgInternalMutex mutex;
217 } libraries = { SG_OBJ(SG_UNDEF),
218 #ifdef LIGHT_WEIGHT_LOCK
219 NULL, 0,
220 #endif
221 };
222
223 #define ALL_LIBRARIES libraries.libraries
224 #define MUTEX libraries.mutex
225 #define OWNER libraries.owner
226 #define COUNT libraries.count
227 /* #ifdef HAVE_SEMAPHORE_H */
228 /* this actually doesn't solve the problem plus causes dead lock. */
229 #if 0
230 static sem_t *process_lock = NULL;
231 # define SEMAPHORE_NAME "/sagittarius-semaphore"
232 # define LOCK_LIBRARIES() \
233 do { \
234 process_lock = sem_open(SEMAPHORE_NAME, O_CREAT, \
235 S_IRUSR|S_IWUSR|S_IRGRP|S_IROTH); \
236 sem_wait(process_lock); \
237 Sg_LockMutex(&MUTEX); \
238 } while (0)
239 # define UNLOCK_LIBRARIES() \
240 do { \
241 Sg_UnlockMutex(&MUTEX); \
242 sem_close(process_lock); \
243 sem_unlink(SEMAPHORE_NAME); \
244 } while (0)
245 #else
246 #ifdef LIGHT_WEIGHT_LOCK
247 /* The small benchmark after the refactoring of library searching
248 it seems a bit faster on multi threading environment to load
249 libraries. This is not really practial but running test requires
250 this thing so not too bad.
251 */
252 # define LOCK_LIBRARIES() \
253 do { \
254 SgVM *vm_ = Sg_VM(); \
255 if (OWNER != vm_) { \
256 for (;;) { \
257 SgVM *owner_; \
258 Sg_LockMutex(&MUTEX); \
259 owner_ = OWNER; \
260 if (owner_ == NULL || \
261 owner_->threadState == SG_VM_TERMINATED) { \
262 OWNER = vm_; \
263 COUNT = 1; \
264 } \
265 Sg_UnlockMutex(&MUTEX); \
266 if (OWNER == vm_) break; \
267 Sg_YieldCPU(); \
268 } \
269 } else { \
270 COUNT++; \
271 } \
272 } while (0)
273 # define UNLOCK_LIBRARIES() \
274 do { \
275 if (--COUNT <= 0) OWNER = NULL; \
276 } while (0)
277 #else
278 # define LOCK_LIBRARIES() Sg_LockMutex(&MUTEX)
279 # define UNLOCK_LIBRARIES() Sg_UnlockMutex(&MUTEX)
280 #endif
281 #endif
282
283
add_library(SgLibrary * lib)284 static SgLibrary * add_library(SgLibrary *lib)
285 {
286 LOCK_LIBRARIES();
287 Sg_HashTableSet(ALL_LIBRARIES, SG_LIBRARY_NAME(lib), lib,
288 SG_HASH_NO_OVERWRITE);
289 UNLOCK_LIBRARIES();
290 return lib;
291 }
292
remove_library(SgLibrary * lib)293 static void remove_library(SgLibrary *lib)
294 {
295 LOCK_LIBRARIES();
296 Sg_HashTableDelete(ALL_LIBRARIES, SG_LIBRARY_NAME(lib));
297 SG_LIBRARY_TABLE(lib) = NULL; /* gc friendliness */
298 UNLOCK_LIBRARIES();
299 }
300
make_library_rec(SgObject name)301 static SgLibrary* make_library_rec(SgObject name)
302 {
303 SgLibrary *z = make_library();
304 /* TODO if it's from Sg_FindLibrary, this is processed twice. */
305 SgObject id_version = library_name_to_id_version(name);
306
307 z->name = convert_name_to_symbol(SG_CAR(id_version));
308 z->version = SG_CDR(id_version);
309
310 return SG_OBJ(add_library(z));
311 }
312
Sg_MakeLibrary(SgObject name)313 SgObject Sg_MakeLibrary(SgObject name)
314 {
315 return SG_OBJ(make_library_rec(name));
316 }
317
Sg_MakeMutableLibrary(SgObject name)318 SgObject Sg_MakeMutableLibrary(SgObject name)
319 {
320 SgLibrary *z = make_library_rec(name);
321 SG_LIBRARY_MUTABLEP(z) = TRUE;
322 return SG_OBJ(z);
323 }
324
Sg_LockLibrary(SgLibrary * library)325 void Sg_LockLibrary(SgLibrary *library)
326 {
327 Sg_LockMutex(&library->lock);
328 SG_LIBRARY_MUTABLEP(library) = FALSE;
329 Sg_UnlockMutex(&library->lock);
330 }
331
332 /* creates anonymous library */
Sg_MakeEvalLibrary()333 SgObject Sg_MakeEvalLibrary()
334 {
335 SgObject name = Sg_MakeSymbol(SG_MAKE_STRING("(eval environment)"), FALSE);
336 return Sg_MakeChildLibrary(Sg_VM(), name);
337 }
338
Sg_MakeChildLibrary(SgVM * vm,SgObject name)339 SgObject Sg_MakeChildLibrary(SgVM *vm, SgObject name)
340 {
341 SgLibrary *z = make_library();
342 z->name = name;
343 z->version = SG_FALSE;
344 z->holder = SG_OBJ(vm); /* eval is also child */
345 SG_LIBRARY_MUTABLEP(z) = TRUE;
346 return z;
347 }
348
Sg_RemoveLibrary(SgLibrary * lib)349 void Sg_RemoveLibrary(SgLibrary *lib)
350 {
351 remove_library(lib);
352 }
353
need_encode(SgChar ch,SgChar * h,SgChar * l)354 static int need_encode(SgChar ch, SgChar *h, SgChar *l)
355 {
356 if (!isalnum(ch) &&
357 (ch == '/' ||
358 ch == '\\' ||
359 ch == ':' ||
360 ch == '*' ||
361 ch == '?' ||
362 ch == '"' ||
363 ch == '<' ||
364 ch == '>' ||
365 ch == '|')){
366 int high = (ch >> 4) & 0xF;
367 int low = ch & 0xF;
368 if (h) {
369 *h = (high < 0xa) ? high + '0' : high + 0x57;
370 }
371 if (l) {
372 *l = (low < 0xa) ? low + '0' : low + 0x57;
373 }
374 return TRUE;
375 } else if (ch >= 128) {
376 Sg_Error(UC("multi byte characters are not supported"
377 " for library name. %A"), SG_MAKE_CHAR(ch));
378 return FALSE; /* dummy */
379 } else {
380 return FALSE;
381 }
382 }
encode_string(SgString * s,int keywordP)383 static SgString* encode_string(SgString *s, int keywordP)
384 {
385 SgString *r;
386 long size = SG_STRING_SIZE(s), i, offset;
387 SgChar high, low;
388 if (keywordP) size += 3; /* extra %3a */
389 /* calculate size */
390 for (i = 0; i < SG_STRING_SIZE(s); i++) {
391 if (need_encode(SG_STRING_VALUE_AT(s, i), NULL, NULL)) {
392 size += 2;
393 }
394 }
395 r = Sg_ReserveString(size, 0);
396 offset = 0;
397 if (keywordP) {
398 SG_STRING_VALUE_AT(r, offset++) = '%';
399 SG_STRING_VALUE_AT(r, offset++) = '3';
400 SG_STRING_VALUE_AT(r, offset++) = 'a';
401 }
402 for (i = 0; i < SG_STRING_SIZE(s); i++) {
403 if (need_encode(SG_STRING_VALUE_AT(s, i), &high, &low)) {
404 SG_STRING_VALUE_AT(r, offset++) = '%';
405 SG_STRING_VALUE_AT(r, offset++) = high;
406 SG_STRING_VALUE_AT(r, offset++) = low;
407 } else {
408 SG_STRING_VALUE_AT(r, offset++) = SG_STRING_VALUE_AT(s, i);
409 }
410 }
411 return r;
412 }
413
414 /*
415 library path convertion must be like this.
416 (lib a b (1)) -> lib/a/b
417 we only manage library id, not version on file system.
418 */
library_name_to_path(SgObject name)419 static SgString* library_name_to_path(SgObject name)
420 {
421 const SgObject separator = Sg_String(Sg_NativeFileSeparator());
422 SgObject item;
423 /* i'm not sure which is better memory.
424 - create a list and string.
425 - append string each time.
426 TODO profile.
427 */
428 SgObject h = SG_NIL, t = SG_NIL;
429
430 if (!SG_PAIRP(name)) {
431 /* for cache */
432 SgObject in = Sg_MakeStringInputPort(SG_SYMBOL(name)->name, 0, -1);
433 name = Sg_Read(in, TRUE);
434 }
435
436 SG_FOR_EACH(item, name) {
437 if (SG_SYMBOLP(SG_CAR(item))) {
438 SgObject o = encode_string(SG_SYMBOL(SG_CAR(item))->name, FALSE);
439 SG_APPEND1(h, t, o);
440 } else if (SG_KEYWORDP(SG_CAR(item))) {
441 /* for srfi-97.
442 NB: when I create srfi library, it must be #!compatible or #!core
443 or else :1 won't be a keyword.
444 */
445 SgObject o = encode_string(SG_KEYWORD(SG_CAR(item))->name, TRUE);
446 SG_APPEND1(h, t, o);
447 } else if (SG_EXACT_INTP(SG_CAR(item))) {
448 SgObject o;
449 if (Sg_Sign(SG_CAR(item)) < 0) goto error;
450 o = Sg_NumberToString(SG_CAR(item), 10, FALSE);
451 SG_APPEND1(h, t, o);
452 } else {
453 error:
454 Sg_Error(UC("library name can contain only symbols, keywords or"
455 " unsigned exact integers"
456 " but got %S"), SG_CAR(item));
457 }
458 if (!SG_NULLP(SG_CDR(item))) {
459 SG_APPEND1(h, t, separator);
460 }
461 }
462 return Sg_StringAppend(h);
463 }
464
465 static SgObject extensions = NULL;
466 static SgObject userlib = NULL;
467 /*
468 this takes only library name part. we don't manage version
469 on file system.
470 */
471 #ifndef MAXPATHLEN
472 #define MAXPATHLEN 1024
473 #endif
474
475 #define ALLOC_TEMP_STRING SG_ALLOC_TEMP_STRING
476
477 #define copy_string(dst, offset, src, start) \
478 do { \
479 int __i; \
480 for (__i = 0; __i < SG_STRING_SIZE(src)-(start); __i++) { \
481 SG_STRING_VALUE_AT(dst, __i+(offset)) = \
482 SG_STRING_VALUE_AT(src, __i+(start)); \
483 } \
484 } while(0)
485
486
487 #define copy_string0(dst, src, offset) \
488 do { \
489 copy_string(dst, offset, src, 0); \
490 (offset) += SG_STRING_SIZE(src); \
491 } while (0)
492
493 #define copy_uz(dst, src, offset, len) \
494 do { \
495 int __i; \
496 for (__i = 0; __i < (len); __i++) { \
497 SG_STRING_VALUE_AT(dst, __i+(offset))=(src)[__i]; \
498 } \
499 (offset) += (len); \
500 } while(0)
501
get_possible_paths(SgVM * vm,SgObject name,int needDirectiveP)502 static SgObject get_possible_paths(SgVM *vm, SgObject name, int needDirectiveP)
503 {
504 /* length of '.sagittarius' */
505 #define SPECIFIC_SIZE 12
506 static const char *specific = ".sagittarius";
507
508 SgString *path;
509 SgObject ext, paths = SG_NIL, t = SG_NIL;
510 SgString *buf;
511 const SgChar *sep = Sg_NativeFileSeparator();
512 size_t sep_size = ustrlen(sep);
513
514 path = library_name_to_path(name);
515 ALLOC_TEMP_STRING(buf, MAXPATHLEN);
516 /* to save some memory */
517 #define check_length(len) if (MAXPATHLEN < offset+(len)) break;
518
519 SG_FOR_EACH(ext, extensions) {
520 SgObject dir;
521 int offset = 0, save, first = TRUE;
522 SG_FOR_EACH(dir, vm->loadPath) {
523 /* first specific otherwise it won't handle specific file properly */
524 check_length(SG_STRING_SIZE(SG_CAR(dir)));
525 copy_string0(buf, SG_CAR(dir), offset);
526 check_length(sep_size);
527 copy_uz(buf, sep, offset, sep_size);
528 check_length(SG_STRING_SIZE(path));
529 copy_string0(buf, path, offset);
530
531 save = offset;
532 check_length(SPECIFIC_SIZE);
533 copy_uz(buf, specific, offset, SPECIFIC_SIZE);
534 second:
535 check_length(SG_STRING_SIZE(SG_CAAR(ext)));
536 copy_string0(buf, SG_CAAR(ext), offset);
537 SG_STRING_VALUE_AT(buf, offset) = 0;
538 SG_STRING_SIZE(buf) = offset;
539 if (Sg_FileExistP(buf)) {
540 if (needDirectiveP) {
541 SG_APPEND1(paths, t, Sg_Cons(Sg_AbsolutePath(buf), SG_CDAR(ext)));
542 } else {
543 SG_APPEND1(paths, t, Sg_AbsolutePath(buf));
544 }
545 }
546 if (first) {
547 first = FALSE;
548 offset = save;
549 goto second;
550 }
551 /* reset */
552 offset = save = 0;
553 first = TRUE;
554 }
555 }
556 #undef check_length
557 return paths;
558 }
559
560 /* FIXME this should be in load.c */
561 static SgTranscoder *default_load_transcoder = SG_UNDEF;
load_library(SgVM * vm,SgObject path,SgObject directive)562 static void load_library(SgVM *vm, SgObject path, SgObject directive)
563 {
564 SgObject file;
565 SgObject bport;
566 SgObject tport;
567 int save = vm->flags;
568 /* dummy context to change VM mode for directive. */
569 SgReadContext context = SG_STATIC_READ_CONTEXT;
570 context.flags = SG_CHANGE_VM_MODE;
571
572 file = Sg_OpenFile(path, SG_READ);
573 if (!SG_FILEP(file)) {
574 /* file is error message */
575 Sg_IOError(SG_IO_FILE_NOT_EXIST_ERROR,
576 SG_INTERN("load"),
577 Sg_Sprintf(UC("given file was not able to open: %A"), file),
578 path, SG_FALSE);
579 }
580 bport = Sg_MakeFileBinaryInputPort(SG_FILE(file), SG_BUFFER_MODE_BLOCK);
581 tport = Sg_MakeTranscodedPort(SG_PORT(bport), default_load_transcoder);
582
583 Sg_ApplyDirective(tport, directive, &context);
584 Sg_LoadFromPort(tport);
585 vm->flags = save;
586 }
587
search_library_unsafe(SgObject name,SgObject olibname,int * loadedp)588 static SgObject search_library_unsafe(SgObject name, SgObject olibname,
589 int *loadedp)
590 {
591 SgObject libname, lib, paths;
592 SgVM *vm = Sg_VM();
593
594 /* pre-check if the library is already compiled, then we don't
595 want to search real path */
596 libname = convert_name_to_symbol(name);
597 lib = Sg_HashTableRef(ALL_LIBRARIES, libname, SG_FALSE);
598 if (!SG_FALSEP(lib)) {
599 return lib;
600 } else if (olibname) {
601 /* if not threre then create, don't search */
602 return Sg_MakeLibrary(olibname);
603 }
604 paths = get_possible_paths(vm, name, TRUE);
605 SG_FOR_EACH(paths, paths) {
606 SgObject r;
607 SgObject path = SG_STRING(SG_CAAR(paths));
608 /* this must creates a new library */
609 if (Sg_FileExistP(path)) {
610 int state, save;
611 /* once library is created, then it must not be re-created.
612 so we need to get lock for reading cache. */
613 lib = Sg_HashTableRef(ALL_LIBRARIES, libname, SG_FALSE);
614 if (!SG_FALSEP(lib)) {
615 return lib;
616 }
617 save = vm->state;
618 vm->state = IMPORTING; /* reading cache is also importing now */
619 /* creates new cache store
620 NOTE:
621 Basically only reading cache doesn't necessarily require
622 fresh cache store. However if the library file contains
623 'load', which loads other library files, outside of the
624 library definition like this:
625 (define-library ...) (load "other/library.sld")
626 Then this calls compile procedure with VM state IMPORTING
627 and causes SEGV (in worst case senario). That's something
628 we don't want to have. To avoid it, add cache store here.
629 */
630 vm->cache = Sg_Cons(SG_NIL, vm->cache);
631 state = Sg_ReadCache(path);
632 if (state != CACHE_READ) {
633 SgObject saveLib = vm->currentLibrary;
634 /* if find-library called inside of library and the library does not
635 import (sagittarius) it can not compile.*/
636 vm->currentLibrary = userlib;
637
638 load_library(vm, path, SG_CDAR(paths)); /* check again, or flag? */
639
640 vm->currentLibrary = saveLib;
641 /* if Sg_ReadCache returns INVALID_CACHE, then we don't have to write
642 it. it's gonna be invalid anyway.
643 */
644 if (state == RE_CACHE_NEEDED) {
645 /* write cache */
646 Sg_WriteCache(name, path, Sg_ReverseX(SG_CAR(vm->cache)));
647 }
648 /* restore state */
649 if (loadedp) *loadedp = TRUE;
650 } else {
651 if (loadedp) *loadedp = FALSE;
652 }
653 /* we don't need the first cache, so discard it */
654 vm->cache = SG_CDR(vm->cache);
655 vm->state = save;
656 } else {
657 /* first creation or no file. */
658 return SG_FALSE;
659 }
660 r = Sg_HashTableRef(ALL_LIBRARIES, libname, SG_FALSE);
661 /*
662 in case of the same base name but different extension.
663 */
664 if (!SG_FALSEP(r)) {
665 if (!SG_FALSEP(SG_LIBRARY_DEFINEED(r)))
666 SG_LIBRARY_DEFINEED(r) = SG_NIL;
667 return r;
668 }
669 }
670 return SG_FALSE;
671 }
672
search_library(SgObject name,SgObject libname,int * loadedp)673 static SgObject search_library(SgObject name, SgObject libname, int *loadedp)
674 {
675 /* TODO should we use unwind_protect? */
676 volatile SgObject r;
677 LOCK_LIBRARIES();
678 SG_UNWIND_PROTECT {
679 r = search_library_unsafe(name, libname, loadedp);
680 } SG_WHEN_ERROR {
681 UNLOCK_LIBRARIES();
682 SG_NEXT_HANDLER;
683 } SG_END_PROTECT;
684 UNLOCK_LIBRARIES();
685 return r;
686 }
687
688 /* for cache */
Sg_SearchLibraryPath(SgObject name)689 SgObject Sg_SearchLibraryPath(SgObject name)
690 {
691 SgObject id_version = library_name_to_id_version(name);
692 return get_possible_paths(Sg_VM(), SG_CAR(id_version), FALSE);
693 }
694
Sg_FindLibrary(SgObject name,int createp)695 SgObject Sg_FindLibrary(SgObject name, int createp)
696 {
697 SgObject id_version;
698
699 /* fast path. for define-syntax. see compiler.scm */
700 if (SG_LIBRARYP(name)) {
701 return name;
702 }
703 id_version = library_name_to_id_version(name);
704 return search_library(SG_CAR(id_version), (createp)? name: NULL, NULL);
705 }
706
707
Sg_SearchLibrary(SgObject lib,int * loadedp)708 SgObject Sg_SearchLibrary(SgObject lib, int *loadedp)
709 {
710 SgObject id_version;
711 /* i'm not sure if i need this, but just in case */
712 if (SG_LIBRARYP(lib)) {
713 return lib;
714 }
715 id_version = library_name_to_id_version(lib);
716 return search_library(SG_CAR(id_version), NULL, loadedp);
717 }
718
719 #define ENSURE_LIBRARY(o, e) \
720 if (SG_LIBRARYP(o)) { \
721 e = SG_LIBRARY(o); \
722 } else { \
723 e = Sg_FindLibrary((o), FALSE); \
724 if (SG_FALSEP(e)) { \
725 Sg_Error(UC("no library named %S"), o); \
726 } \
727 }
728
import_parents(SgLibrary * fromlib,SgObject spec)729 static SgObject import_parents(SgLibrary *fromlib, SgObject spec)
730 {
731 SgObject parents = fromlib->parents;
732 /* we need to check if fromlib's export spec exports variables */
733 SgObject exported = SG_NIL, cp;
734 SG_FOR_EACH(cp, parents) {
735 SgObject lib = SG_CAAR(cp);
736 SgObject alist = SG_CDAR(cp);
737 SgObject h = SG_NIL, t = SG_NIL;
738 if (!SG_NULLP(alist) && SG_EQ(fromlib, SG_CAR(alist))) {
739 SG_APPEND(h, t, Sg_Cons(lib, spec));
740 }
741 if (!SG_NULLP(h)) {
742 exported = Sg_Acons(lib, h, exported);
743 }
744 }
745 return exported;
746 }
747
export_read_macro_p(SgObject specs)748 static int export_read_macro_p(SgObject specs)
749 {
750 SgObject cp;
751 SG_FOR_EACH(cp, specs) {
752 SgObject spec = SG_CAR(cp);
753 if (SG_EQ(SG_CAR(spec), SG_SYMBOL_ONLY)) {
754 if (SG_FALSEP(Sg_Memq(SG_KEYWORD_EXPORT_READER_MACRO, SG_CDR(spec)))) {
755 return FALSE;
756 }
757 } else if (SG_EQ(SG_CAR(spec), SG_SYMBOL_EXCEPT)) {
758 if (!SG_FALSEP(Sg_Memq(SG_KEYWORD_EXPORT_READER_MACRO, SG_CDR(spec)))) {
759 return FALSE;
760 }
761 }
762 }
763 return TRUE;
764 }
765
import_reader_macro(SgLibrary * to,SgLibrary * from,SgObject spec)766 static void import_reader_macro(SgLibrary *to, SgLibrary *from, SgObject spec)
767 {
768 /* try */
769 if (SG_LIBRARY_READTABLE(from)) {
770 /* now we don't want to import reader macro when explicitly excluded
771 or spec has only so that the hierarchy of read macro chain would be
772 cut.
773 Some users are very neat so in that case if :export-reader-macro
774 is specified in only clause then we allow it.
775 */
776 if (export_read_macro_p(spec)) {
777 SG_LIBRARY_READTABLE(to) = Sg_CopyReadTable(SG_LIBRARY_READTABLE(from));
778 }
779 }
780 }
781
782 /*
783 To keep imported library be resolved by imported order, we need to do some
784 ugly trick. The goal for the trick is importing libraries parents order
785 like this;
786
787 ;; importing
788 ;; foo has parent library (foo parent) and (foo) is exporting its variable.
789 (import (buzz))
790 (import (foo) (bar))
791
792 library parents must be like this;
793 ((#<(bar)> ...)
794 (#<(foo)> ...)
795 (#<(foo parent)> ...)
796 (#<(buzz)> ...))
797
798 The purpos for this is, if (buzz) contains the same exported variable as
799 (foo parent) does, then (foo parent)'s one must be used. R6RS actually
800 prohibits this behaviour, however it's inconvenient for me. So we allow to
801 overwrite exported variables and resolve it as it's imported.
802 */
Sg_ImportLibraryFullSpec(SgObject to,SgObject from,SgObject spec)803 void Sg_ImportLibraryFullSpec(SgObject to, SgObject from, SgObject spec)
804 {
805 SgLibrary *tolib, *fromlib;
806 SgObject parents, slot, exportSpec;
807 SgVM *vm = Sg_VM();
808
809 ENSURE_LIBRARY(to, tolib);
810 ENSURE_LIBRARY(from, fromlib);
811 Sg_LockMutex(&tolib->lock);
812
813 slot = Sg_Cons(fromlib, SG_NIL);
814 exportSpec = SG_LIBRARY_EXPORTED(fromlib);
815 if (SG_VM_LOG_LEVEL(vm, SG_DEBUG_LEVEL)) {
816 Sg_Printf(vm->logPort, UC(";; importing library from %S to %S: %S\n"),
817 SG_LIBRARY_NAME(from), SG_LIBRARY_NAME(to), spec);
818 }
819 SG_LIBRARY_IMPORTED(tolib) = Sg_Acons(fromlib, spec,
820 SG_LIBRARY_IMPORTED(tolib));
821 {
822 /* means something is defined, we add all information here */
823 SgObject h = SG_NIL, t = SG_NIL;
824 SG_APPEND(h, t, Sg_Cons(fromlib, spec));
825 SG_SET_CDR(slot, h);
826 }
827 parents = import_parents(fromlib, spec);
828
829 tolib->parents = Sg_Append2X(Sg_Cons(slot, parents), tolib->parents);
830 if (!SG_FALSEP(exportSpec)) {
831 if (!SG_FALSEP(Sg_Memq(SG_KEYWORD_EXPORT_READER_MACRO,
832 SG_CAR(exportSpec)))) {
833 import_reader_macro(tolib, fromlib, spec);
834 }
835 if (!SG_FALSEP(Sg_Memq(SG_KEYWORD_EXPORT_READER, SG_CAR(exportSpec)))) {
836 SG_LIBRARY_READER(tolib) = SG_LIBRARY_READER(fromlib);
837 }
838 } else {
839 import_reader_macro(tolib, fromlib, spec);
840 SG_LIBRARY_READER(tolib) = SG_LIBRARY_READER(fromlib);
841 }
842
843 Sg_UnlockMutex(&tolib->lock);
844 }
845
Sg_LibraryExportedSet(SgObject lib,SgObject exportSpec)846 void Sg_LibraryExportedSet(SgObject lib, SgObject exportSpec)
847 {
848 SgLibrary *l;
849 ENSURE_LIBRARY(lib, l);
850 SG_LIBRARY_EXPORTED(l) = exportSpec;
851 }
852
library_export_all_p(SgLibrary * lib)853 static int library_export_all_p(SgLibrary *lib)
854 {
855 if (SG_FALSEP(SG_LIBRARY_EXPORTED(lib))) return TRUE;
856 return !SG_FALSEP(Sg_Memq(SG_KEYWORD_ALL, SG_CAR(SG_LIBRARY_EXPORTED(lib))));
857 }
858
Sg_MakeBinding(SgLibrary * lib,SgSymbol * symbol,SgObject value,int flags)859 SgGloc* Sg_MakeBinding(SgLibrary *lib, SgSymbol *symbol,
860 SgObject value, int flags)
861 {
862 SgGloc *g;
863 SgObject v;
864 SgObject oldval = SG_UNDEF;
865 int prev_const = FALSE;
866 Sg_LockMutex(&lib->lock);
867
868 v = Sg_HashTableRef(lib->table, symbol, SG_FALSE);
869 if (SG_GLOCP(v)) {
870 g = SG_GLOC(v);
871 prev_const = Sg_GlocConstP(g);
872 oldval = SG_GLOC_GET(g);
873 } else {
874 g = SG_GLOC(Sg_MakeGloc(symbol, lib));
875 Sg_HashTableSet(lib->table, symbol, SG_OBJ(g), 0);
876 }
877
878 if (SG_LIBRARY_AUTO_EXPORT(lib) && !library_export_all_p(lib)) {
879 /* now we need to push to exported */
880 SgObject exported = SG_LIBRARY_EXPORTED(lib);
881 if (SG_FALSEP(Sg_Memq(symbol, SG_CAR(exported)))) {
882 SG_SET_CAR(exported, Sg_Cons(symbol, SG_CAR(exported)));
883 }
884 }
885
886 Sg_UnlockMutex(&lib->lock);
887
888 SG_GLOC_SET(g, value);
889 /* NB: for now, only TRUE or FALSE */
890 g->constant = flags;
891
892 if (prev_const) {
893 if (prev_const != flags || !Sg_EqualP(value, oldval)) {
894 Sg_Warn(UC("constant value %S bounded with %S was overwitten by %S"),
895 oldval, symbol, value);
896 }
897 }
898 return g;
899 }
900
901 /* utility */
cadr_assq(SgObject v,SgObject l)902 static SgObject cadr_assq(SgObject v, SgObject l)
903 {
904 SgObject cp;
905 SG_FOR_EACH(cp, l) {
906 SgObject slot = SG_CAR(cp);
907 if (SG_PAIRP(slot) && SG_EQ(v, SG_CADR(slot))) return slot;
908 }
909 return SG_FALSE;
910 }
911
two_memq(SgObject v1,SgObject v2,SgObject l)912 static SgObject two_memq(SgObject v1, SgObject v2, SgObject l)
913 {
914 SgObject cp;
915 SG_FOR_EACH(cp, l) {
916 SgObject o = SG_CAR(cp);
917 if (SG_EQ(v1, o) || SG_EQ(v2, o)) return o;
918 }
919 return SG_FALSE;
920 }
921
922
923 /*
924 To save some memory allocation, we resolve variables renaming at runtime.
925 The library parents structure is now like this;
926 ((<lib> <parent-lib> . <import spec>) ...)
927 */
unrename_variable(SgObject key,SgObject specs)928 static SgObject unrename_variable(SgObject key, SgObject specs)
929 {
930 SgObject cp;
931
932 if (SG_NULLP(specs)) return key;
933
934 SG_FOR_EACH(cp, specs) {
935 SgObject spec = SG_CAR(cp);
936 if (SG_EQ(SG_CAR(spec), SG_SYMBOL_ONLY)) {
937 if (SG_FALSEP(Sg_Memq(key, SG_CDR(spec)))) return SG_FALSE;
938 } else if (SG_EQ(SG_CAR(spec), SG_SYMBOL_RENAME)) {
939 if (SG_FALSEP(Sg_Assq(key, SG_CDR(spec)))) {
940 SgObject rename = cadr_assq(key, SG_CDR(spec));
941 if (!SG_FALSEP(rename)) key = SG_CAR(rename);
942 } else {
943 return SG_FALSE;
944 }
945 } else if (SG_EQ(SG_CAR(spec), SG_SYMBOL_EXCEPT)) {
946 if (!SG_FALSEP(Sg_Memq(key, SG_CDR(spec)))) return SG_FALSE;
947 } else if (SG_EQ(SG_CAR(spec), SG_SYMBOL_PREFIX)) {
948 SgObject prefix, name, buf;
949 int i;
950 name = SG_SYMBOL(key)->name;
951 prefix = SG_SYMBOL(SG_CDR(spec))->name;
952 /* obvious case */
953 if (SG_STRING_SIZE(name) < SG_STRING_SIZE(prefix)) return SG_FALSE;
954 for (i = 0; i < SG_STRING_SIZE(prefix); i++) {
955 if (SG_STRING_VALUE_AT(prefix, i) != SG_STRING_VALUE_AT(name, i))
956 return SG_FALSE;
957 }
958 ALLOC_TEMP_STRING(buf, SG_STRING_SIZE(name) - i);
959 copy_string(buf, 0, name, i);
960 key = Sg_Intern(buf);
961 }
962 }
963 return key;
964 }
965
find_binding(SgObject sandbox,SgObject library,SgObject olibrary,SgObject oname,SgObject callback)966 static SgGloc* find_binding(SgObject sandbox,
967 SgObject library,
968 SgObject olibrary,
969 SgObject oname,
970 SgObject callback)
971 {
972 SgLibrary *lib /* , *olib */;
973 SgObject ret, name = oname;
974 ASSERT(SG_SYMBOLP(name));
975
976 if (SG_LIBRARYP(library)) lib = SG_LIBRARY(library);
977 else if (SG_FALSEP(library)) lib = Sg_VMCurrentLibrary();
978 else lib = Sg_FindLibrary(library, FALSE);
979 if (SG_FALSEP(lib)) return callback;
980
981 /* olib = lib; */ /* keep it */
982 reent:
983 if (!SG_FALSEP(sandbox)) {
984 ret = Sg_HashTableRef(sandbox, Sg_Cons(lib, oname), SG_UNBOUND);
985 if (!SG_UNBOUNDP(ret)) return ret;
986 }
987 /* first look up from library table */
988 ret = Sg_HashTableRef(SG_LIBRARY_TABLE(lib), name, SG_UNBOUND);
989 if (SG_UNBOUNDP(ret)) {
990 /* second we need to look up from parents */
991 SgObject cp;
992 SG_FOR_EACH(cp, lib->parents) {
993 /* (<lib> <parent-lib> . spec) */
994 SgObject head = SG_CAR(cp);
995 SgObject plib = SG_CADR(head), spec = SG_CDDR(head);
996 /* TODO reverse it in compile time */
997 SgObject unrenamed = unrename_variable(name, spec);
998 if (!SG_FALSEP(unrenamed)) {
999 /* if parent exports it, do it recursively */
1000 SgObject pexport = SG_LIBRARY_EXPORTED(plib);
1001 SgObject slot = SG_FALSE;
1002 SgObject mq = SG_FALSE;
1003 if (SG_FALSEP(pexport) ||
1004 !SG_FALSEP((mq = two_memq(unrenamed, SG_KEYWORD_ALL,
1005 SG_CAR(pexport)))) ||
1006 !SG_FALSEP((slot = cadr_assq(unrenamed, SG_CDR(pexport))))) {
1007 /* some manual optimisation */
1008 if (!SG_FALSEP(slot)) {
1009 lib = plib; name = SG_CAR(slot);
1010 goto reent;
1011 } else {
1012 /* c stub or :all doesn't always have the variables,
1013 so we need to keep searching. */
1014 if (SG_FALSEP(pexport) || SG_EQ(SG_KEYWORD_ALL, mq)) {
1015 ret = find_binding(sandbox, plib, olibrary, unrenamed, callback);
1016 if (ret != callback) {
1017 /*
1018 Originally we implmeneted library more statically means
1019 all imported variables are resolved in compile time.
1020 then I thought it's rather waste of memory to keep
1021 all binding which can be refer by following the
1022 imported libraries. This is a really trade off
1023 of memory and speed. Storing all bindings into one
1024 single hashtable isn't good for memory usage.
1025
1026 NB: enabling below commented out code improves
1027 calling find-binding 74757 times: 120ms -> 20ms
1028
1029 If this bothers me alot in future, we can always
1030 enable this for a bit of performance.
1031 */
1032 /* Sg_HashTableSet(SG_LIBRARY_TABLE(olib), oname, ret, */
1033 /* SG_HASH_NO_OVERWRITE); */
1034 goto out;
1035 }
1036 } else {
1037 lib = plib; name = unrenamed;
1038 goto reent;
1039 }
1040 }
1041 }
1042 }
1043 }
1044 ret = callback;
1045 }
1046 out:
1047 return ret;
1048 }
1049
Sg_FindBinding(SgObject library,SgObject name,SgObject callback)1050 SgGloc* Sg_FindBinding(SgObject library, SgObject name, SgObject callback)
1051 {
1052 SgLibrary *lib;
1053 ENSURE_LIBRARY(library, lib);
1054 return find_binding(Sg_VM()->sandbox, lib, lib, name, callback);
1055 }
1056
wrap_library(SgObject library)1057 static SgLibrary *wrap_library(SgObject library) {
1058 SgLibrary *lib = make_library();
1059 lib->name = SG_INTERN("(sandbox dummy)");
1060 lib->version = SG_FALSE;
1061 Sg_ImportLibrary(lib, library);
1062 return lib;
1063 }
1064
Sg_InsertSandboxBinding(SgObject library,SgObject name,SgObject value)1065 void Sg_InsertSandboxBinding(SgObject library, SgObject name, SgObject value)
1066 {
1067 SgVM *vm = Sg_VM();
1068 SgGloc *g;
1069 SgObject key, lib, v;
1070 if (SG_FALSEP(vm->sandbox)) {
1071 Sg_AssertionViolation(SG_INTERN("insert-sandbox-binding"),
1072 SG_MAKE_STRING("sandbox is not enabled"),
1073 SG_NIL);
1074 }
1075 /* ENSURE_LIBRARY(library, lib); */
1076 lib = wrap_library(library);
1077 v = find_binding(SG_FALSE, lib, lib, name, SG_UNBOUND);
1078 if (SG_UNBOUNDP(v)) {
1079 Sg_AssertionViolation(SG_INTERN("insert-sandbox-binding"),
1080 Sg_Sprintf(UC("no binding named '%S' in '%S'"),
1081 name, library),
1082 SG_LIST2(library, name));
1083 }
1084 ENSURE_LIBRARY(library, lib);
1085 key = Sg_Cons(lib, name);
1086 g = SG_GLOC(Sg_MakeGloc(name, lib));
1087 Sg_HashTableSet(vm->sandbox, key, SG_OBJ(g), 0);
1088 SG_GLOC_SET(g, value);
1089 }
1090
Sg_InsertBinding(SgLibrary * library,SgObject name,SgObject value_or_gloc)1091 void Sg_InsertBinding(SgLibrary *library, SgObject name, SgObject value_or_gloc)
1092 {
1093 SgObject value;
1094 if (SG_GLOCP(value_or_gloc)) {
1095 value = SG_GLOC_GET(SG_GLOC(value_or_gloc));
1096 } else {
1097 value = value_or_gloc;
1098 }
1099 if (SG_SYMBOLP(name)) {
1100 Sg_MakeBinding(library, name, value, 0);
1101 } else if (SG_IDENTIFIERP(name)) {
1102 Sg_MakeBinding(library, SG_IDENTIFIER_NAME(name), value, 0);
1103 } else {
1104 Sg_Error(UC("symbol or identifier required, but got %S"), name);
1105 }
1106 }
1107
Sg_FindDefaultDirectiveByPath(SgObject path)1108 SgObject Sg_FindDefaultDirectiveByPath(SgObject path)
1109 {
1110 SgObject cp;
1111 if (SG_STRINGP(path)) {
1112 SG_FOR_EACH(cp, extensions) {
1113 SgObject conf = SG_CAR(cp);
1114 long length = SG_STRING_SIZE(SG_CAR(conf));
1115 long plen = SG_STRING_SIZE(path);
1116 long i,j;
1117 if (plen < length) goto fallback;
1118 for (i = length-1, j = plen-1; i >= 0; i--, j--) {
1119 if (SG_STRING_VALUE_AT(SG_CAR(conf), i) != SG_STRING_VALUE_AT(path, j))
1120 break;
1121 }
1122 if (i < 0) return SG_CDR(conf);
1123 }
1124 }
1125 fallback:
1126 return SG_INTERN("compatible");
1127 }
1128
1129 static SgInternalMutex suffix_mutex;
Sg_AddLoadSuffix(SgObject conf,int appendP)1130 SgObject Sg_AddLoadSuffix(SgObject conf, int appendP)
1131 {
1132 SgObject o = SG_UNDEF;
1133 if (SG_STRINGP(conf)) {
1134 o = Sg_Cons(SG_STRING(conf), SG_INTERN("compatible"));
1135 } else if (SG_PAIRP(conf)) {
1136 if (SG_STRINGP(SG_CAR(conf)) && SG_SYMBOLP(SG_CDR(conf))) {
1137 o = conf;
1138 } else {
1139 goto err;
1140 }
1141 } else {
1142 err:
1143 Sg_Error(UC("string or pair of string and symbol required but got %S"),
1144 conf);
1145 }
1146 /* check if this looks like a suffix */
1147 if (SG_STRING_VALUE_AT(SG_CAR(o), 0) != '.') {
1148 return SG_FALSE;
1149 }
1150 Sg_LockMutex(&suffix_mutex);
1151 if (appendP && !SG_NULLP(extensions)) {
1152 extensions = Sg_AddConstantLiteral(Sg_Append2X(extensions,
1153 SG_LIST1(o)));
1154 } else {
1155 extensions = Sg_AddConstantLiteral(Sg_Cons(o, extensions));
1156 }
1157 Sg_UnlockMutex(&suffix_mutex);
1158 return extensions;
1159 }
1160
1161 /* #define list6(a, b, c, d, e, f) Sg_Cons(a, SG_LIST5(b,c,d,e,f)) */
Sg__InitLibrary()1162 void Sg__InitLibrary()
1163 {
1164 Sg_InitMutex(&MUTEX, TRUE);
1165 Sg_InitMutex(&suffix_mutex, FALSE);
1166 ALL_LIBRARIES = Sg_MakeHashTableSimple(SG_HASH_EQ, 1024);
1167
1168 extensions =
1169 SG_LIST4(Sg_Cons(SG_MAKE_STRING(".ss"), SG_INTERN("r6rs")),
1170 Sg_Cons(SG_MAKE_STRING(".sls"), SG_INTERN("r6rs")),
1171 /* well, i don't like this but for my convenience */
1172 Sg_Cons(SG_MAKE_STRING(".sld"), SG_INTERN("r7rs")),
1173 Sg_Cons(SG_MAKE_STRING(".scm"), SG_INTERN("compatible")));
1174 extensions = Sg_AddConstantLiteral(extensions);
1175 userlib = Sg_MakeMutableLibrary(SG_INTERN("user"));
1176
1177 default_load_transcoder = SG_TRANSCODER(Sg_MakeTranscoder(Sg_MakeUtf8Codec(),
1178 Sg_NativeEol(),
1179 SG_RAISE_ERROR));
1180 }
1181
1182 /*
1183 end of file
1184 Local Variables:
1185 coding: utf-8-unix
1186 End:
1187 */
1188