1 /* core.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 <string.h>
31 #include <sagittarius/config.h>
32 #ifdef HAVE_UNISTD_H
33 # include <unistd.h>
34 #endif
35 #define LIBSAGITTARIUS_BODY
36 #include "sagittarius/gc.h"
37 #include "sagittarius/private.h"
38 #include "sagittarius/private/core.h"
39 #include "sagittarius/private/vm.h"
40 #include "sagittarius/private/builtin-symbols.h"
41 #include "sagittarius/private/keyword.h"
42
43 #include "gc-incl.inc"
44
45 static void finalizable(void);
46
oom_handler(size_t bytes)47 static void* oom_handler(size_t bytes)
48 {
49 Sg_Panic("out of memory (%lu). aborting...", bytes);
50 return NULL; /* dummy */
51 }
52
53 static void init_cond_features();
54
55 extern void Sg__InitSymbol();
56 extern void Sg__InitNumber();
57 extern void Sg__InitString();
58 extern void Sg__InitKeyword();
59 extern void Sg__InitLibrary();
60 extern void Sg__InitFile();
61 extern void Sg__InitPair();
62 extern void Sg__InitRecord();
63 extern void Sg__InitConditions();
64 extern void Sg__InitReader();
65 extern void Sg__InitPort();
66 extern void Sg__InitLoad();
67 extern void Sg__InitVM();
68 extern void Sg__InitCache();
69 extern void Sg__InitCharSet();
70 extern void Sg__InitClos();
71 extern void Sg__InitIdentifier();
72 extern void Sg__InitWrite();
73 extern void Sg__InitRegex();
74 extern void Sg__InitUnicode();
75 extern void Sg__InitMacro();
76 extern void Sg__InitSystem();
77 extern void Sg__InitBaseSystem(); /* for <time>, maybe I should make time.c */
78 extern void Sg__InitReaderClass();
79
80 /* stub files */
81 extern void Sg__Init_sagittarius_compiler_procedure();
82 extern void Sg__Init_sagittarius_vm_debug();
83 extern void Sg__Init_sagittarius_vm();
84 extern void Sg__Init_sagittarius();
85 extern void Sg__Init_sagittarius_clos();
86 extern void Sg__Init_sagittarius_fixnums();
87 extern void Sg__Init_sagittarius_flonums();
88 extern void Sg__Init_sagittarius_treemap();
89 extern void Sg__Init_sagittarius_sandbox();
90 extern void Sg__InitInstruction();
91 /* compiled libraries */
92 extern void Sg__Init_core();
93 extern void Sg__Init_core_base();
94 extern void Sg__Init_core_macro();
95 extern void Sg__Init_sagittarius_compiler_util();
96 extern void Sg__Init_sagittarius_compiler();
97 /* these must be the last */
98 extern void Sg__Init_core_errors();
99 extern void Sg__Init_core_arithmetic();
100 extern void Sg__Init_core_program();
101
102 extern void Sg__InitExtFeatures();
103 extern void Sg__InitComparator();
104
105 extern void Sg__PostInitVM();
106 extern void Sg__PostInitCache();
107
108 #define IS_NEW_GC_VERSION (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR >= 2) \
109 || GC_VERSION_MAJOR > 7
110
111 #ifdef USE_BOEHM_GC
112 static GC_warn_proc warn_proc = NULL;
no_warning(char * msg,GC_word arg)113 static void no_warning(char * msg, GC_word arg)
114 {
115 /* do nothing */
116 }
117
Sg_GCSetPrintWarning(int onP)118 void Sg_GCSetPrintWarning(int onP)
119 {
120 /* */
121 if (onP) {
122 #if IS_NEW_GC_VERSION
123 GC_set_warn_proc(warn_proc);
124 #endif
125 } else {
126 GC_set_warn_proc(no_warning);
127 }
128 }
129
130 #endif
131
Sg_Init()132 void Sg_Init()
133 {
134 SgObject nullsym, coreBase, compsym, sgsym;
135 #ifdef USE_BOEHM_GC
136 GC_INIT();
137 GC_allow_register_threads();
138 #if IS_NEW_GC_VERSION
139 GC_set_oom_fn(oom_handler);
140 GC_set_finalize_on_demand(TRUE);
141 GC_set_finalizer_notifier(finalizable);
142 /* GC_get_warn_proc is after 7.2 */
143 warn_proc = GC_get_warn_proc();
144 #else
145 GC_oom_fn = oom_handler;
146 GC_finalize_on_demand = TRUE;
147 GC_finalizer_notifier = finalizable;
148 #endif
149 #else
150 /* do nothing for now*/
151 #endif
152
153
154 /* order is important especially libraries */
155 Sg__InitString(); /* string must be before symbol */
156 Sg__InitSymbol();
157 Sg__InitNumber();
158 Sg__InitKeyword();
159 /* initialize default reader macro */
160 Sg__InitReader();
161
162 Sg__InitLibrary();
163 Sg__InitLoad();
164 Sg__InitUnicode();
165
166 Sg__InitVM();
167 /* init clos uses findlibrary. so after VM */
168 Sg__InitClos();
169 Sg__InitBaseSystem(); /* <time> */
170 Sg__InitReaderClass();
171 Sg__InitMacro();
172 /* port must be after VM to replace std ports. */
173 Sg__InitPort();
174 Sg__InitWrite();
175 Sg__InitIdentifier();
176 Sg__InitCache();
177
178 nullsym = SG_INTERN("(core)");
179 coreBase = SG_INTERN("(core base)");
180 compsym = SG_INTERN("(sagittarius compiler)");
181 sgsym = SG_INTERN("(sagittarius)");
182
183 /* for (core syntax-case) we need compler library to create global id.
184 so create it here
185 */
186 Sg_FindLibrary(compsym, TRUE);
187
188 Sg__InitInstruction();
189 Sg__Init_core();
190 Sg__Init_sagittarius();
191 Sg__InitPair();
192 Sg__InitCharSet();
193 Sg__InitFile();
194
195 /* regex */
196 Sg__InitRegex();
197 /* for Windows but call it */
198 Sg__InitSystem();
199
200 Sg__InitComparator(); /* need (core) and (sagittarius) */
201 Sg__Init_sagittarius_vm();
202 Sg__Init_sagittarius_vm_debug();
203 Sg__Init_sagittarius_clos();
204 Sg__Init_sagittarius_fixnums();
205 Sg__Init_sagittarius_flonums();
206 Sg__Init_sagittarius_treemap();
207
208 /* this is scmlib.scm */
209 Sg__Init_core_base();
210 /* record can be here. */
211 Sg__InitRecord();
212 Sg__InitConditions();
213
214 Sg_ImportLibrary(coreBase, nullsym);
215
216 Sg__Init_core_errors();
217 Sg__Init_core_macro();
218 Sg__Init_sagittarius_compiler_util();
219 Sg__Init_sagittarius_compiler_procedure();
220 Sg__Init_sagittarius_compiler();
221 /* even these files need to be ordered */
222 Sg__Init_core_arithmetic();
223 Sg__Init_core_program();
224 /* we need to put basic syntaxes to compiler. */
225 Sg_ImportLibrary(compsym, nullsym);
226 Sg_ImportLibrary(compsym, sgsym);
227
228 /* this requires macro so after (core macro) */
229 Sg__Init_sagittarius_sandbox();
230
231 /*
232 rebind er-macro-transformer into (sagittarius)
233 */
234 {
235 SgObject core_macro = SG_INTERN("(core macro)");
236 SgLibrary *core_macro_lib = SG_LIBRARY(Sg_FindLibrary(core_macro, FALSE));
237 SgLibrary *sagittarius_lib = SG_LIBRARY(Sg_FindLibrary(sgsym, FALSE));
238 Sg_InsertBinding(sagittarius_lib,
239 SG_SYMBOL_ER_MACRO_TRANSFORMER,
240 Sg_FindBinding(core_macro_lib,
241 SG_SYMBOL_ER_MACRO_TRANSFORMER,
242 SG_UNBOUND));
243 }
244 init_cond_features();
245
246 /* Sg__Port* will be called after all initialisations are done. */
247 Sg__PostInitVM();
248 Sg__PostInitCache();
249
250 /* this is required to even import or so on user library */
251 Sg_ImportLibraryFullSpec(Sg_VM()->currentLibrary, sgsym,
252 SG_LIST1(SG_LIST4(SG_INTERN("only"),
253 SG_INTERN("import"),
254 SG_INTERN("library"),
255 SG_INTERN("define-library"))));
256 }
257
258 /* GC related */
Sg_malloc(size_t size)259 void* Sg_malloc(size_t size)
260 {
261 #ifdef USE_BOEHM_GC
262 return GC_MALLOC(size);
263 #else
264 /* for now do nothing */
265 return NULL;
266 #endif
267 }
Sg_malloc_atomic(size_t size)268 void* Sg_malloc_atomic(size_t size)
269 {
270 #ifdef USE_BOEHM_GC
271 return GC_MALLOC_ATOMIC(size);
272 #else
273 /* for now do nothing */
274 return NULL;
275 #endif
276 }
277
Sg_GetHeapSize()278 size_t Sg_GetHeapSize()
279 {
280 return GC_get_heap_size();
281 }
Sg_GetTotalBytes()282 size_t Sg_GetTotalBytes()
283 {
284 return GC_get_total_bytes();
285 }
Sg_GcCount()286 uintptr_t Sg_GcCount()
287 {
288 #if IS_NEW_GC_VERSION
289 return GC_get_gc_no();
290 #else
291 return GC_gc_no;
292 #endif
293 }
294
295 /* may fail on some platform */
Sg_GCStackBase(uintptr_t * base)296 int Sg_GCStackBase(uintptr_t *base)
297 {
298 /* cache for stack base (for performance)
299 It seems GC_get_stack_base is really slow on Linux. This affects
300 performance of bignum caluculation (especially cryptographic
301 operation such as RSA key generation). I don't think modern
302 operating system can change stack base of created thread, so
303 we can cache it here.
304 TODO: getting too many rabbish on VM...
305 */
306 #if defined(_MSC_VER) || defined(_SG_WIN_SUPPORT)
307 static __declspec(thread) uintptr_t cStackBase = (uintptr_t)-1;
308 #else
309 /* we go easier way. (hope it works on portably) */
310 static __thread uintptr_t cStackBase = (uintptr_t)-1;
311 #endif
312 struct GC_stack_base b;
313
314 if (cStackBase != (uintptr_t)-1) {
315 *base = cStackBase;
316 return TRUE;
317 } else {
318 int ok = GC_get_stack_base(&b);
319 if (ok == GC_SUCCESS) {
320 cStackBase = (uintptr_t)b.mem_base;
321 *base = cStackBase;
322 return TRUE;
323 }
324 *base = (uintptr_t)-1;
325 return FALSE;
326 }
327 }
328
329 /* not sure if we need to do this but just in case
330 this saves some stack space to execute.
331 */
332 #define CONTROL_AREA 0x1000
stack_limit()333 static intptr_t stack_limit()
334 {
335 if (Sg_MainThreadP()) {
336 return SG_MAIN_THREAD_STACK_SIZE_LIMIT - CONTROL_AREA;
337 } else {
338 return SG_CHILD_THREAD_STACK_SIZE_LIMIT - CONTROL_AREA;
339 }
340 }
341 /*
342 usage:
343 volatile char current_stack;
344 intptr_t size = Sg_AvailableStackSize(¤t_stack);
345 */
Sg_AvailableStackSize(uintptr_t csp)346 intptr_t Sg_AvailableStackSize(uintptr_t csp)
347 {
348 uintptr_t base;
349 intptr_t limit = stack_limit();
350 if (Sg_GCStackBase(&base)) {
351 /* TODO it's assume stack grows downward */
352 return limit - (base - csp);
353 }
354 /* sorry we just return max size. don't blame me... */
355 return limit;
356 }
357
Sg_GC()358 void Sg_GC()
359 {
360 #ifdef USE_BOEHM_GC
361 GC_gcollect();
362 #else
363 /* for now do nothing */
364 #endif
365 }
366
Sg_RegisterFinalizer(void * z,void (* finalizer)(void *,void *),void * data)367 void Sg_RegisterFinalizer(void *z, void(*finalizer)(void *, void *), void *data)
368 {
369 #ifdef USE_BOEHM_GC
370 GC_finalization_proc ofn; void *ocd;
371 GC_REGISTER_FINALIZER_NO_ORDER(z, finalizer, data, &ofn, &ocd);
372 #else
373 /* for now do nothing */
374 #endif
375 }
376
Sg_UnregisterFinalizer(void * z)377 void Sg_UnregisterFinalizer(void *z)
378 {
379 #ifdef USE_BOEHM_GC
380 GC_finalization_proc ofn; void *ocd;
381 GC_REGISTER_FINALIZER_NO_ORDER(z, (GC_finalization_proc)NULL, NULL,
382 &ofn, &ocd);
383 #else
384 /* for now do nothing */
385 #endif
386 }
387
Sg_IsFinalizerRegistered(void * z)388 int Sg_IsFinalizerRegistered(void *z)
389 {
390 return Sg_FinalizerRegisteredP(z);
391 }
392
Sg_FinalizerRegisteredP(SgObject z)393 int Sg_FinalizerRegisteredP(SgObject z)
394 {
395 #ifdef USE_BOEHM_GC
396 GC_finalization_proc ofn, dfn;
397 void *ocd, *dcd;
398 /* it's a bit ugly to do it but we need this unfortunately... */
399 GC_REGISTER_FINALIZER_NO_ORDER(z, (GC_finalization_proc)NULL,
400 NULL, &ofn, &ocd);
401 GC_REGISTER_FINALIZER_NO_ORDER(z, ofn, ocd, &dfn, &dcd);
402 return (void *)ofn != NULL;
403 #else
404 /* for now do nothing */
405 #endif
406 }
407
Sg_RegisterDisappearingLink(void ** p,void * value)408 void Sg_RegisterDisappearingLink(void **p, void *value)
409 {
410 #ifdef USE_BOEHM_GC
411 GC_general_register_disappearing_link(p, value);
412 #else
413 /* for now do nothing */
414 #endif
415 }
416
Sg_UnregisterDisappearingLink(void ** p)417 void Sg_UnregisterDisappearingLink(void **p)
418 {
419 #ifdef USE_BOEHM_GC
420 GC_unregister_disappearing_link(p);
421 #else
422 /* for now do nothing */
423 #endif
424 }
425
Sg_GCBase(void * value)426 void* Sg_GCBase(void *value)
427 {
428 #ifdef USE_BOEHM_GC
429 return GC_base(value);
430 #else
431 /* for now do nothing */
432 return NULL;
433 #endif
434 }
435
finalizable()436 void finalizable()
437 {
438 SgVM *vm = Sg_VM();
439 if (vm) {
440 vm->finalizerPending = TRUE;
441 vm->attentionRequest = TRUE;
442 }
443 }
444
Sg_VMFinalizerRun(SgVM * vm)445 SgObject Sg_VMFinalizerRun(SgVM *vm)
446 {
447 /* for future we want to use own gc implementation */
448 #ifdef USE_BOEHM_GC
449 retry:
450 vm->finalizerPending = FALSE;
451 GC_invoke_finalizers();
452 /* If finalizers consumes memory and GC is invoked during
453 calling finalizer, then the pending flag is set to TRUE
454 and finalizers need to be called again.
455
456 NB: not sure if we need to do this much.
457 */
458 if (vm->finalizerPending) goto retry;
459
460 vm->finalizerPending = FALSE;
461 return SG_UNDEF;
462 #else
463 return SG_UNDEF;
464 #endif
465 }
466
Sg_RegisterDL(void * data_start,void * data_end,void * bss_start,void * bss_end)467 void Sg_RegisterDL(void *data_start, void *data_end,
468 void *bss_start, void *bss_end)
469 {
470 if (data_start < data_end) {
471 Sg_AddGCRoots(data_start, data_end);
472 }
473 if (bss_start < bss_end) {
474 Sg_AddGCRoots(bss_start, bss_end);
475 }
476 }
477
Sg_AddGCRoots(void * start,void * end)478 void Sg_AddGCRoots(void *start, void *end)
479 {
480 #ifdef USE_BOEHM_GC
481 GC_add_roots(start, end);
482 #else
483 /* do nothing for now */
484 #endif
485 }
486
Sg_InvokeOnAlienThread(void * (* func)(void * data),void * data)487 void* Sg_InvokeOnAlienThread(void * (*func)(void *data), void *data)
488 {
489 #ifdef USE_BOEHM_GC
490 /* the func is called here and from here, the memory is managed by the GC */
491 struct GC_stack_base sb;
492 void *r;
493 GC_get_stack_base(&sb);
494 GC_register_my_thread(&sb);
495 r = func(data);
496 GC_unregister_my_thread();
497 return r;
498 #else
499 /* do nothing for now */
500 #endif
501 }
502
503 /* exit related */
504 #define EXIT_CODE(code) ((code)&0xFF)
505
Sg_Exit(int code)506 void Sg_Exit(int code)
507 {
508 Sg_Cleanup();
509 exit(EXIT_CODE(code));
510 }
511
Sg_EmergencyExit(int code)512 void Sg_EmergencyExit(int code)
513 {
514 exit(EXIT_CODE(code));
515 }
516
517 struct cleanup_handler_rec
518 {
519 void (*handler)(void *);
520 void *data;
521 struct cleanup_handler_rec *next;
522 };
523
524 static struct {
525 int dirty;
526 struct cleanup_handler_rec *handlers;
527 } cleanup = { TRUE, NULL };
528
Sg_Cleanup()529 void Sg_Cleanup()
530 {
531 SgVM *vm = Sg_VM();
532 SgObject hp;
533 struct cleanup_handler_rec *ch;
534
535 if (!cleanup.dirty) return;
536 cleanup.dirty = FALSE;
537
538 SG_FOR_EACH(hp, vm->dynamicWinders) {
539 vm->dynamicWinders = SG_CDR(hp);
540 Sg_Apply0(SG_CDAR(hp));
541 }
542
543 for (ch = cleanup.handlers; ch; ch = ch->next) {
544 ch->handler(ch->data);
545 }
546
547 Sg_FlushAllPort(TRUE);
548 return;
549 }
550
Sg_AddCleanupHandler(void (* proc)(void * data),void * data)551 void* Sg_AddCleanupHandler(void (*proc)(void *data), void *data)
552 {
553 struct cleanup_handler_rec *h = SG_NEW(struct cleanup_handler_rec);
554 h->handler = proc;
555 h->data = data;
556 h->next = cleanup.handlers;
557 cleanup.handlers = h;
558 return h;
559 }
560
Sg_DeleteCleanupHandler(void * handle)561 void Sg_DeleteCleanupHandler(void *handle)
562 {
563 struct cleanup_handler_rec *x = NULL, *y = cleanup.handlers;
564 while (y) {
565 if (y == handle) {
566 if (x == NULL) {
567 cleanup.handlers = y->next;
568 } else {
569 x->next = y->next;
570 }
571 break;
572 }
573 }
574 }
575
Sg_Panic(const char * msg,...)576 void Sg_Panic(const char* msg, ...)
577 {
578 va_list args;
579 va_start(args, msg);
580 vfprintf(stderr, msg, args);
581 va_end(args);
582 fputc('\n', stderr);
583 fflush(stderr);
584 _exit(EXIT_CODE(1));
585 }
586
Sg_Abort(const char * msg)587 void Sg_Abort(const char* msg)
588 {
589 int size = (int)strlen(msg);
590 #ifndef _MSC_VER
591 ssize_t r = write(2, msg, size);
592 if (r < 0) {
593 _exit(EXIT_CODE(errno));
594 }
595 #else
596 DWORD n;
597 WriteConsoleA(GetStdHandle(STD_ERROR_HANDLE), msg, size, &n, NULL);
598 #endif
599 _exit(EXIT_CODE(1));
600 }
601
602 static struct {
603 SgObject list;
604 SgInternalMutex mutex;
605 } cond_features = { SG_NIL };
606
Sg_AddCondFeature(const SgChar * feature)607 void Sg_AddCondFeature(const SgChar *feature)
608 {
609 if (!Sg_MainThreadP()) {
610 Sg_Error(UC("child thread can not add cond-feature"));
611 }
612 Sg_LockMutex(&cond_features.mutex);
613 cond_features.list = Sg_Cons(Sg_Intern(Sg_String(feature)),
614 cond_features.list);
615 Sg_AddConstantLiteral(cond_features.list);
616 Sg_UnlockMutex(&cond_features.mutex);
617 }
618
Sg_CondFeatures()619 SgObject Sg_CondFeatures()
620 {
621 return cond_features.list;
622 }
623
init_cond_features()624 static void init_cond_features()
625 {
626 Sg_InitMutex(&cond_features.mutex, FALSE);
627 Sg_AddCondFeature(UC("sagittarius"));
628 Sg_AddCondFeature(UC("sagittarius.os."SAGITTARIUS_PLATFORM));
629 /* R7RS appendix B */
630 Sg_AddCondFeature(UC("r7rs"));
631 Sg_AddCondFeature(UC("ratios"));
632 Sg_AddCondFeature(UC("exact-closed"));
633 Sg_AddCondFeature(UC("exact-complex"));
634 Sg_AddCondFeature(UC("ieee-float"));
635 Sg_AddCondFeature(UC("full-unicode"));
636 Sg_AddCondFeature(UC(SAGITTARIUS_PLATFORM));
637 Sg_AddCondFeature(UC(SAGITTARIUS_PROCESSOR));
638 /* it's useful for FFI */
639 #if SIZEOF_VOIDP == 8
640 Sg_AddCondFeature(UC("64bit"));
641 #else
642 Sg_AddCondFeature(UC("32bit"));
643 #endif
644
645 #ifdef WORDS_BIGENDIAN
646 Sg_AddCondFeature(UC("big-endian"));
647 #else
648 Sg_AddCondFeature(UC("little-endian"));
649 #endif
650 Sg_AddCondFeature(UC("sagittarius-"SAGITTARIUS_VERSION));
651 /* maybe it's useful */
652 Sg_AddCondFeature(UC(SAGITTARIUS_TRIPLE));
653 /* regexp (SRFI-115)
654 I don't like the name regexp but that's how it is on the SRFI.
655 */
656 Sg_AddCondFeature(UC("regexp-non-greedy"));
657 Sg_AddCondFeature(UC("regexp-look-around"));
658 Sg_AddCondFeature(UC("regexp-backrefs"));
659 Sg_AddCondFeature(UC("regexp-unicode"));
660
661 /* extlib features */
662 Sg__InitExtFeatures();
663 }
664
665 /* Starting point of the Sagittarius engine */
Sg_Start(SgObject fileOrPort,SgObject commandLine,const char * fmt,SgObject rest)666 void Sg_Start(SgObject fileOrPort, SgObject commandLine,
667 const char *fmt, SgObject rest)
668 {
669 SgObject lib = Sg_FindLibrary(SG_INTERN("(core program)"), FALSE);
670 SgObject args = SG_NIL;
671 SgObject start = Sg_FindBinding(lib, SG_INTERN("start"), SG_UNBOUND);
672
673 if (SG_UNBOUNDP(start)) Sg_Panic("`start` is not found");
674 if (SG_LISTP(rest)) {
675 while (*fmt) {
676 if (SG_NULLP(rest)) break;
677 #define CASE(_c, _k) \
678 case _c: \
679 args = Sg_Acons(SG_MAKE_KEYWORD(_k), SG_CAR(rest), args); \
680 rest = SG_CDR(rest); \
681 break
682
683 switch (*fmt++) {
684 CASE('s', "standard");
685 CASE('p', "preimports");
686 CASE('e', "expressions");
687 CASE('m', "main?");
688 CASE('i', "interactive?");
689 default: break;
690 }
691 }
692 }
693 Sg_Apply3(SG_GLOC_GET(SG_GLOC(start)), fileOrPort, commandLine, args);
694
695 }
696 /* somehow Visual Studio 2010 requires this to create dll.*/
697 #ifdef _MSC_VER
main()698 int main()
699 {
700 return 0;
701 }
702 #endif
703
704 /*
705 end of file
706 Local Variables:
707 coding: utf-8-unix
708 End:
709 */
710