1 /*===========================================================================
2 * Filename : sigscheme.c
3 * About : Client interfaces
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include <stdlib.h>
41 #include <stdio.h>
42 #include <string.h>
43
44 #include "sigscheme.h"
45 #include "sigschemeinternal.h"
46 #if SCM_USE_MULTIBYTE_CHAR
47 #include "encoding.h"
48 #else
49 #include "encoding-dummy.h"
50 #endif
51 #if SCM_USE_EVAL_C_STRING
52 #include "scmport-config.h"
53 #include "scmport.h"
54 #include "scmport-str.h"
55 #endif
56
57 /*=======================================
58 File Local Macro Definitions
59 =======================================*/
60 #if !SCM_USE_CONTINUATION
61 #define scm_p_call_with_current_continuation NULL
62 #define scm_p_dynamic_wind NULL
63 #endif
64
65 /*=======================================
66 File Local Type Definitions
67 =======================================*/
68
69 /*=======================================
70 Variable Definitions
71 =======================================*/
72 #include "functable-sscm-core.c"
73 #include "functable-r5rs-core.c"
74 #if SCM_USE_READER
75 #include "functable-r5rs-read.c"
76 #endif
77 #if SCM_USE_QUASIQUOTE
78 #include "functable-r5rs-qquote.c"
79 #endif
80 #if SCM_USE_NUMBER
81 #include "functable-r5rs-number.c"
82 #endif
83 #if (SCM_USE_NUMBER_IO && SCM_USE_STRING)
84 #include "functable-r5rs-number-io.c"
85 #endif
86 #if SCM_USE_CHAR
87 #include "functable-r5rs-char.c"
88 #endif
89 #if SCM_USE_STRING
90 #include "functable-r5rs-string.c"
91 #endif
92 #if SCM_USE_STRING_PROCEDURE
93 #include "functable-r5rs-string-procedure.c"
94 #endif
95 #if SCM_USE_VECTOR
96 #include "functable-r5rs-vector.c"
97 #endif
98 #if SCM_USE_DEEP_CADRS
99 #include "functable-r5rs-deep-cadrs.c"
100 #endif
101
102 SCM_GLOBAL_VARS_BEGIN(static_sigscheme);
103 #define static
104 static scm_bool l_scm_initialized;
105 #undef static
106 SCM_GLOBAL_VARS_END(static_sigscheme);
107 #define l_scm_initialized SCM_GLOBAL_VAR(static_sigscheme, l_scm_initialized)
108 SCM_DEFINE_STATIC_VARS(static_sigscheme);
109
110 static const char *const builtin_features[] = {
111 "sigscheme",
112 #if SCM_USE_INTERNAL_DEFINITIONS
113 "internal-definitions",
114 #endif
115 #if SCM_STRICT_TOPLEVEL_DEFINITIONS
116 "strict-toplevel-definitions",
117 #endif
118 #if SCM_NESTED_CONTINUATION_ONLY
119 "nested-continuation-only",
120 #endif
121 #if SCM_STRICT_R5RS
122 "strict-r5rs",
123 #endif
124 #if SCM_STRICT_ARGCHECK
125 "strict-argcheck",
126 #endif
127 #if SCM_STRICT_NULL_FORM
128 "strict-null-form",
129 #endif
130 #if SCM_STRICT_VECTOR_FORM
131 "strict-vector-form",
132 #endif
133 #if SCM_STRICT_ENCODING_CHECK
134 "strict-encoding-check",
135 #endif
136 #if (SCM_CONST_LIST_LITERAL && SCM_HAS_IMMUTABLE_CONS)
137 "const-list-literal",
138 #endif
139 #if (SCM_CONST_VECTOR_LITERAL && SCM_HAS_IMMUTABLE_VECTOR)
140 "const-vector-literal",
141 #endif
142 #if SCM_USE_DEEP_CADRS
143 "deep-cadrs",
144 #endif
145 #if SCM_COMPAT_SIOD
146 "compat-siod",
147 #endif
148 #if SCM_COMPAT_SIOD_BUGS
149 "siod-bugs",
150 #endif
151 #if SCM_USE_NULL_CAPABLE_STRING
152 "null-capable-string",
153 #endif
154 #if SCM_HAS_IMMEDIATE_CHAR_ONLY
155 "immediate-char-only",
156 #endif
157 #if SCM_HAS_IMMEDIATE_NUMBER_ONLY
158 "immediate-number-only",
159 #endif
160 #if SCM_USE_MULTIBYTE_CHAR
161 "multibyte-char",
162 #endif
163 #if SCM_USE_UTF8
164 "utf-8",
165 #endif
166 #if SCM_USE_EUCCN
167 "euc-cn",
168 #endif
169 #if SCM_USE_EUCJP
170 "euc-jp",
171 #endif
172 #if SCM_USE_EUCKR
173 "euc-kr",
174 #endif
175 #if SCM_USE_SJIS
176 "shift-jis",
177 #endif
178 NULL
179 };
180
181 /*=======================================
182 File Local Function Declarations
183 =======================================*/
184 static char **scm_initialize_internal(const char *const *argv);
185 #if SCM_USE_EVAL_C_STRING
186 static void *scm_eval_c_string_internal(const char *exp);
187 #endif
188 static void argv_err(char **argv, const char *err_msg);
189
190 /*=======================================
191 Function Definitions
192 =======================================*/
193 /**
194 * Initialize the interpreter
195 *
196 * @param storage_conf Storage configuration parameters. NULL instructs
197 * default.
198 */
199 SCM_EXPORT char **
scm_initialize(const ScmStorageConf * storage_conf,const char * const * argv)200 scm_initialize(const ScmStorageConf *storage_conf, const char *const *argv)
201 {
202 char **rest_argv;
203
204 SCM_AGGREGATED_GLOBAL_VARS_INIT();
205
206 scm_encoding_init();
207 scm_init_storage(storage_conf);
208
209 rest_argv = scm_call_with_gc_ready_stack((ScmGCGateFunc)scm_initialize_internal, (void *)argv);
210
211 l_scm_initialized = scm_true;
212
213 return rest_argv;
214 }
215
216 static char **
scm_initialize_internal(const char * const * argv)217 scm_initialize_internal(const char *const *argv)
218 {
219 const char *const *feature;
220 char **rest_argv;
221
222 rest_argv = (char **)argv;
223
224 /* size constraints */
225 /* FIXME: check at compile-time */
226 if (!((SCM_SAL_PTR_BITS <= SIZEOF_VOID_P * CHAR_BIT)
227 && (SCM_SAL_CHAR_BITS <= SIZEOF_SCM_ICHAR_T * CHAR_BIT)
228 && (SCM_SAL_INT_BITS <= SIZEOF_SCM_INT_T * CHAR_BIT)
229 && (SCM_SAL_STRLEN_BITS <= SCM_SAL_INT_BITS)
230 && (SCM_SAL_VECLEN_BITS <= SCM_SAL_INT_BITS)))
231 scm_fatal_error("bit width constraints of the storage implementation are broken");
232
233 if (!((SCM_SAL_CHAR_MAX <= SCM_ICHAR_T_MAX)
234 && (SCM_INT_T_MIN <= SCM_SAL_INT_MIN
235 && SCM_SAL_INT_MAX <= SCM_INT_T_MAX)
236 && (SCM_SAL_STRLEN_MAX <= SCM_SAL_INT_MAX)
237 && (SCM_SAL_VECLEN_MAX <= SCM_SAL_INT_MAX)))
238 scm_fatal_error("size constraints of the storage implementation are broken");
239
240 /*=======================================================================
241 Core
242 =======================================================================*/
243 SCM_GLOBAL_VARS_INIT(procedure);
244 SCM_GLOBAL_VARS_INIT(static_sigscheme);
245
246 scm_init_error();
247 scm_set_debug_categories(SCM_DBG_ERRMSG | SCM_DBG_BACKTRACE
248 | scm_predefined_debug_categories());
249
250 #if SCM_USE_WRITER
251 scm_init_writer();
252 #endif
253 #if SCM_USE_FORMAT
254 /* FIXME: duplicate call with scm_initialize_srfi{28,48}() */
255 scm_init_format();
256 #endif
257 #if SCM_USE_READER
258 scm_register_funcs(scm_functable_r5rs_read);
259 #endif
260 #if SCM_USE_LOAD
261 scm_init_load();
262 #endif
263 scm_init_module();
264
265 /* fallback to unibyte */
266 scm_identifier_codec = scm_mb_find_codec("UTF-8");
267
268 /*=======================================================================
269 Register Built-in Functions
270 =======================================================================*/
271 /* pseudo procedure to deliver multiple values to an arbitrary procedure
272 * (assigns an invalid continuation as unique ID) */
273 scm_gc_protect_with_init(&scm_values_applier, MAKE_CONTINUATION());
274
275 /* SigScheme-specific core syntaxes and procedures */
276 scm_register_funcs(scm_functable_sscm_core);
277
278 /* R5RS Syntaxes */
279 scm_init_syntax();
280 #if SCM_USE_QUASIQUOTE
281 scm_register_funcs(scm_functable_r5rs_qquote);
282 #endif
283 #if SCM_USE_HYGIENIC_MACRO
284 scm_init_macro();
285 #endif
286 #if SCM_USE_PROMISE
287 scm_init_promise();
288 #endif
289
290 /* R5RS Procedures */
291 scm_register_funcs(scm_functable_r5rs_core);
292 #if !SCM_USE_CONTINUATION
293 SCM_SYMBOL_SET_VCELL(scm_intern("call-with-current-continuation"), SCM_UNBOUND);
294 SCM_SYMBOL_SET_VCELL(scm_intern("call-with-values"), SCM_UNBOUND);
295 #endif
296 #if SCM_USE_NUMBER
297 scm_register_funcs(scm_functable_r5rs_number);
298 #endif
299 #if (SCM_USE_NUMBER_IO && SCM_USE_STRING)
300 scm_register_funcs(scm_functable_r5rs_number_io);
301 #endif
302 #if SCM_USE_CHAR
303 scm_register_funcs(scm_functable_r5rs_char);
304 #endif
305 #if SCM_USE_STRING
306 scm_register_funcs(scm_functable_r5rs_string);
307 #endif
308 #if SCM_USE_STRING_PROCEDURE
309 scm_register_funcs(scm_functable_r5rs_string_procedure);
310 #endif
311 #if SCM_USE_VECTOR
312 scm_register_funcs(scm_functable_r5rs_vector);
313 #endif
314 #if SCM_USE_DEEP_CADRS
315 scm_register_funcs(scm_functable_r5rs_deep_cadrs);
316 #endif
317
318 /* for distinction from SRFI-1 versions */
319 scm_define_alias("r5rs:map", "map");
320 scm_define_alias("r5rs:for-each", "for-each");
321 scm_define_alias("r5rs:member", "member");
322 scm_define_alias("r5rs:assoc", "assoc");
323
324 /* for distinction from SRFI-9 overridings */
325 scm_define_alias("r5rs:vector?", "vector?");
326 scm_define_alias("r5rs:eval", "eval");
327
328 #if SCM_USE_LEGACY_MACRO
329 scm_init_legacy_macro();
330 #endif
331 #if SCM_USE_SSCM_EXTENSIONS
332 scm_require_module("sscm-ext");
333 #endif
334 #if SCM_USE_EVAL_C_STRING
335 scm_require_module("srfi-6");
336 #endif
337
338 /*=======================================================================
339 Fixing up
340 =======================================================================*/
341 /* to evaluate SigScheme-dependent scheme codes conditionally */
342 for (feature = &builtin_features[0]; *feature; feature++)
343 scm_provide(CONST_STRING(*feature));
344
345 /* Since SCM_SAL_PTR_BITS may use sizeof() instead of autoconf SIZEOF
346 * macro, #if is not safe here. */
347 if (SCM_PTR_BITS == 64)
348 scm_provide(CONST_STRING("64bit-addr"));
349
350 if (argv)
351 rest_argv = scm_interpret_argv((char **)argv); /* safe cast */
352
353 #if SCM_USE_PORT
354 /* To apply -C <encoding> option for scm_{in,out,err} ports, this
355 * invocation is placed after scm_interpret_argv() */
356 scm_init_port();
357 #endif
358 #if SCM_USE_LOAD
359 /* Load additional procedures written in Scheme */
360 scm_load_system_file("sigscheme-init.scm");
361 #endif
362
363 #if SCM_USE_SRFI55
364 /* require-extension is enabled by default */
365 scm_require_module("srfi-55");
366 #endif
367 #if SCM_USE_SRFI0
368 /* cond-expand is enabled by default */
369 scm_s_srfi55_require_extension(LIST_1(LIST_2(scm_intern("srfi"),
370 MAKE_INT(0))),
371 SCM_INTERACTION_ENV);
372 #endif
373
374 return rest_argv;
375 }
376
377 SCM_EXPORT void
scm_finalize()378 scm_finalize()
379 {
380 #if SCM_USE_LOAD
381 scm_fin_load();
382 #endif
383 scm_fin_module();
384 scm_fin_storage();
385 l_scm_initialized = scm_false;
386
387 SCM_GLOBAL_VARS_FIN(procedure);
388 SCM_GLOBAL_VARS_FIN(static_sigscheme);
389 SCM_AGGREGATED_GLOBAL_VARS_FIN();
390 }
391
392 #if SCM_USE_EVAL_C_STRING
393 SCM_EXPORT ScmObj
scm_eval_c_string(const char * exp)394 scm_eval_c_string(const char *exp)
395 {
396 return (ScmObj)scm_call_with_gc_ready_stack((ScmGCGateFunc)scm_eval_c_string_internal, (void *)exp);
397 }
398
399 static void *
scm_eval_c_string_internal(const char * exp)400 scm_eval_c_string_internal(const char *exp)
401 {
402 ScmObj str_port, ret;
403 ScmBytePort *bport;
404 ScmCharPort *cport;
405
406 bport = ScmInputStrPort_new_const(exp, NULL);
407 cport = scm_make_char_port(bport);
408 str_port = MAKE_PORT(cport, SCM_PORTFLAG_INPUT);
409
410 ret = scm_read(str_port);
411 ret = EVAL(ret, SCM_INTERACTION_ENV);
412
413 return (void *)ret;
414 }
415 #endif /* SCM_USE_EVAL_C_STRING */
416
417 SCM_EXPORT ScmObj
scm_array2list(void ** ary,size_t len,ScmObj (* conv)(void *))418 scm_array2list(void **ary, size_t len, ScmObj (*conv)(void *))
419 {
420 void **p;
421 ScmObj elm, lst;
422 ScmQueue q;
423 DECLARE_INTERNAL_FUNCTION("scm_array2list");
424
425 SCM_ASSERT(ary);
426 SCM_ASSERT(len <= SCM_INT_T_MAX);
427
428 lst = SCM_NULL;
429 SCM_QUEUE_POINT_TO(q, lst);
430 for (p = &ary[0]; p < &ary[len]; p++) {
431 elm = (conv) ? (*conv)(*p) : (ScmObj)(*p);
432 SCM_QUEUE_ADD(q, elm);
433 }
434
435 return lst;
436 }
437
438 SCM_EXPORT void **
scm_list2array(ScmObj lst,size_t * len,void * (* conv)(ScmObj))439 scm_list2array(ScmObj lst, size_t *len, void *(*conv)(ScmObj))
440 {
441 scm_int_t scm_len;
442 void **ary, **p;
443 ScmObj elm;
444 DECLARE_INTERNAL_FUNCTION("scm_list2array");
445
446 scm_len = scm_length(lst);
447 if (!SCM_LISTLEN_PROPERP(scm_len))
448 ERR("proper list required");
449
450 *len = (size_t)scm_len;
451 p = ary = scm_malloc(*len * sizeof(void *));
452 FOR_EACH (elm, lst)
453 *p++ = (conv) ? (*conv)(elm) : (void *)elm;
454
455 return ary;
456 }
457
458 static void
argv_err(char ** argv,const char * err_msg)459 argv_err(char **argv, const char *err_msg)
460 {
461 DECLARE_INTERNAL_FUNCTION("scm_interpret_argv");
462
463 if (l_scm_initialized) {
464 scm_free_argv(argv);
465 ERR(err_msg);
466 } else {
467 fputs(SCM_ERR_HEADER, stderr);
468 fputs(err_msg, stderr);
469 fputs("\n", stderr);
470 exit(EXIT_FAILURE);
471 }
472 }
473
474 /* TODO: parse properly */
475 /* don't access ScmObj if (!l_scm_initialized) */
476 SCM_EXPORT char **
scm_interpret_argv(char ** argv)477 scm_interpret_argv(char **argv)
478 {
479 char **argp, **rest;
480 const char *encoding, *sys_load_path;
481 #if SCM_USE_MULTIBYTE_CHAR
482 ScmCharCodec *specified_codec;
483 ScmObj err_obj;
484 #endif
485 DECLARE_INTERNAL_FUNCTION("scm_interpret_argv");
486
487 encoding = sys_load_path = NULL;
488 argp = &argv[0];
489 if (strcmp(argv[0], "/usr/bin/env") == 0)
490 argp++;
491 if (*argp)
492 argp++; /* skip executable name */
493
494 /* parse options */
495 for (; *argp; argp++) {
496 if ((*argp)[0] != '-')
497 break; /* script name appeared */
498
499 if (strcmp(*argp, "-C") == 0) {
500 /* character encoding */
501 encoding = *++argp;
502 if (!encoding)
503 argv_err(argv, "no encoding name specified");
504 } else if (strcmp(*argp, "--system-load-path") == 0) {
505 /* system load path */
506 sys_load_path = *++argp;
507 if (!sys_load_path)
508 argv_err(argv, "no system load path specified");
509 } else {
510 argv_err(argv, "invalid option");
511 }
512 }
513 rest = argp;
514
515 /* apply options */
516 if (encoding) {
517 #if SCM_USE_MULTIBYTE_CHAR
518 specified_codec = scm_mb_find_codec(encoding);
519 if (!specified_codec) {
520 if (l_scm_initialized) {
521 err_obj = CONST_STRING(encoding);
522 scm_free_argv(argv);
523 ERR_OBJ(ERRMSG_UNSUPPORTED_ENCODING, err_obj);
524 } else {
525 fprintf(stderr,
526 SCM_ERR_HEADER ERRMSG_UNSUPPORTED_ENCODING ": %s\n",
527 encoding);
528 exit(EXIT_FAILURE);
529 }
530 }
531 scm_current_char_codec = specified_codec;
532 #else
533 argv_err(argv, ERRMSG_CODEC_SW_NOT_SUPPORTED);
534 #endif
535 }
536
537 if (sys_load_path) {
538 scm_set_system_load_path(sys_load_path);
539 }
540
541 return rest;
542 }
543
544 SCM_EXPORT void
scm_free_argv(char ** argv)545 scm_free_argv(char **argv)
546 {
547 char **argp;
548
549 for (argp = &argv[0]; *argp; argp++) {
550 free(*argp);
551 }
552 free(argv);
553 }
554