1 /*
2
3 Copyright (c) 2003-2013 uim Project https://github.com/uim/uim
4
5 All rights reserved.
6
7 Redistribution and use in source and binary forms, with or without
8 modification, are permitted provided that the following conditions
9 are met:
10
11 1. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
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 3. Neither the name of authors nor the names of its contributors
17 may be used to endorse or promote products derived from this software
18 without specific prior written permission.
19
20 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
21 ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
24 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26 OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27 HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
28 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
29 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
30 SUCH DAMAGE.
31
32 */
33
34 /*
35 * To avoid namespace pollution, all SigScheme functions and variables
36 * are defined as static and wrapped into uim-scm.c by direct
37 * inclusion instead of being linked via public symbols.
38 * -- YamaKen 2004-12-21, 2005-01-10, 2006-04-02
39 */
40 /* This file must be included before uim's config.h */
41 #include "sigscheme-combined.c"
42 #if !SSCM_VERSION_REQUIRE(0, 8, 5)
43 #error "SigScheme version 0.8.5 or later is required"
44 #endif
45
46 #include <config.h>
47
48 #include <stdio.h>
49 #include <stdlib.h>
50 #include <string.h>
51 #include <ctype.h>
52 #include <stdarg.h>
53 #include <assert.h>
54
55 #include "uim-scm.h"
56 /* To avoid macro name conflict with SigScheme, uim-scm-abbrev.h should not
57 * be included. */
58
59
60 static uim_lisp protected;
61 static uim_bool initialized;
62
63 static void *uim_scm_error_internal(const char *msg);
64 struct uim_scm_error_obj_args {
65 const char *msg;
66 uim_lisp errobj;
67 };
68 static void *uim_scm_error_obj_internal(struct uim_scm_error_obj_args *args);
69
70 struct call_args {
71 uim_lisp proc;
72 uim_lisp args;
73 uim_lisp failed;
74 };
75 static void *uim_scm_call_internal(struct call_args *args);
76 static void *uim_scm_call_with_guard_internal(struct call_args *args);
77
78 struct callf_args {
79 const char *proc;
80 const char *args_fmt;
81 va_list args;
82 uim_bool with_guard;
83 uim_lisp failed;
84 };
85 static void *uim_scm_callf_internal(struct callf_args *args);
86
87 static void *uim_scm_c_int_internal(void *uim_lisp_integer);
88 static void *uim_scm_make_int_internal(void *integer);
89 static void *uim_scm_c_char_internal(void *uim_lisp_ch);
90 static void *uim_scm_make_char_internal(intptr_t ch);
91 static const char *uim_scm_refer_c_str_internal(void *uim_lisp_str);
92 static void *uim_scm_make_str_internal(const char *str);
93 static void *uim_scm_make_str_directly_internal(char *str);
94 static void *uim_scm_make_symbol_internal(const char *name);
95 static void *uim_scm_make_ptr_internal(void *ptr);
96 static void *uim_scm_make_func_ptr_internal(uim_func_ptr func_ptr);
97 static void *uim_scm_symbol_value_internal(const char *symbol_str);
98 static void *uim_scm_symbol_value_int_internal(const char *symbol_str);
99 static char *uim_scm_symbol_value_str_internal(const char *symbol_str);
100 struct array2list_args {
101 void **ary;
102 size_t len;
103 uim_lisp (*conv)(void *);
104 };
105 static void *uim_scm_array2list_internal(struct array2list_args *args);
106 struct list2array_args {
107 uim_lisp lst;
108 size_t *len;
109 void *(*conv)(uim_lisp);
110 };
111 static void *uim_scm_list2array_internal(struct list2array_args *args);
112 struct array2vector_args {
113 void **ary;
114 size_t len;
115 uim_lisp (*conv)(void *);
116 };
117 static void *uim_scm_array2vector_internal(struct array2vector_args *args);
118 struct vector2array_args {
119 uim_lisp vec;
120 size_t *len;
121 void *(*conv)(uim_lisp);
122 };
123 static void *uim_scm_vector2array_internal(struct vector2array_args *args);
124 static void *uim_scm_eval_internal(void *uim_lisp_obj);
125 static void *uim_scm_quote_internal(void *obj);
126 struct cons_args {
127 uim_lisp car;
128 uim_lisp cdr;
129 };
130 static void *uim_scm_cons_internal(struct cons_args *args);
131
132
133 void
uim_scm_set_fatal_error_hook(void (* hook)(void))134 uim_scm_set_fatal_error_hook(void (*hook)(void))
135 {
136 scm_set_fatal_error_callback(hook);
137 }
138
139 void
uim_scm_error(const char * msg)140 uim_scm_error(const char *msg)
141 {
142 assert(uim_scm_gc_any_contextp());
143 assert(msg);
144
145 uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_error_internal, (char *)msg);
146 }
147
148 static void *
uim_scm_error_internal(const char * msg)149 uim_scm_error_internal(const char *msg)
150 {
151 scm_plain_error(msg);
152 SCM_NOTREACHED;
153 }
154
155 void
uim_scm_error_obj(const char * msg,uim_lisp errobj)156 uim_scm_error_obj(const char *msg, uim_lisp errobj)
157 {
158 struct uim_scm_error_obj_args args;
159
160 assert(uim_scm_gc_any_contextp());
161 assert(msg);
162 assert(uim_scm_gc_protectedp(errobj));
163
164 args.msg = msg;
165 args.errobj = errobj;
166 uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_error_obj_internal, &args);
167 }
168
169 static void *
uim_scm_error_obj_internal(struct uim_scm_error_obj_args * args)170 uim_scm_error_obj_internal(struct uim_scm_error_obj_args *args)
171 {
172 scm_error_obj(NULL, args->msg, (ScmObj)args->errobj);
173 SCM_NOTREACHED;
174 }
175
176 /* can be passed to uim_scm_list2null_term_array() */
177 long
uim_scm_c_bool(uim_lisp val)178 uim_scm_c_bool(uim_lisp val)
179 {
180 assert(uim_scm_gc_any_contextp());
181
182 return (uim_scm_truep(val)) ? UIM_TRUE : UIM_FALSE;
183 }
184
185 /* can be passed to uim_scm_array2list() */
186 uim_lisp
uim_scm_make_bool(long val)187 uim_scm_make_bool(long val)
188 {
189 assert(uim_scm_gc_any_contextp());
190
191 return (val) ? uim_scm_t() : uim_scm_f();
192 }
193
194 long
uim_scm_c_int(uim_lisp integer)195 uim_scm_c_int(uim_lisp integer)
196 {
197 assert(uim_scm_gc_any_contextp());
198 assert(uim_scm_gc_protectedp(integer));
199
200 return (long)(intptr_t)uim_scm_call_with_gc_ready_stack(uim_scm_c_int_internal, (void *)integer);
201 }
202
203 static void *
uim_scm_c_int_internal(void * uim_lisp_integer)204 uim_scm_c_int_internal(void *uim_lisp_integer)
205 {
206 long c_int;
207 uim_lisp integer;
208
209 integer = (uim_lisp)uim_lisp_integer;
210
211 if (!SCM_INTP((ScmObj)integer))
212 uim_scm_error_obj("uim_scm_c_int: number required but got ", integer);
213
214 c_int = SCM_INT_VALUE((ScmObj)integer);
215 return (void *)(intptr_t)c_int;
216 }
217
218 uim_lisp
uim_scm_make_int(long integer)219 uim_scm_make_int(long integer)
220 {
221 assert(uim_scm_gc_any_contextp());
222
223 return (uim_lisp)uim_scm_call_with_gc_ready_stack(uim_scm_make_int_internal,
224 (void *)(intptr_t)integer);
225 }
226
227 static void *
uim_scm_make_int_internal(void * integer)228 uim_scm_make_int_internal(void *integer)
229 {
230 return (void *)SCM_MAKE_INT((intptr_t)integer);
231 }
232
233 long
uim_scm_c_char(uim_lisp ch)234 uim_scm_c_char(uim_lisp ch)
235 {
236 assert(uim_scm_gc_any_contextp());
237 assert(uim_scm_gc_protectedp(ch));
238
239 return (long)(intptr_t)uim_scm_call_with_gc_ready_stack(uim_scm_c_char_internal, (void *)ch);
240 }
241
242 static void *
uim_scm_c_char_internal(void * uim_lisp_ch)243 uim_scm_c_char_internal(void *uim_lisp_ch)
244 {
245 scm_ichar_t ch;
246 uim_lisp ch_;
247
248 ch_ = (uim_lisp)uim_lisp_ch;
249
250 if (!SCM_CHARP((ScmObj)ch_))
251 uim_scm_error_obj("uim_scm_c_char: char required but got ", ch_);
252
253 ch = SCM_CHAR_VALUE((ScmObj)ch_);
254 return (void *)(intptr_t)ch;
255 }
256
257 uim_lisp
uim_scm_make_char(long ch)258 uim_scm_make_char(long ch)
259 {
260 assert(uim_scm_gc_any_contextp());
261
262 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_make_char_internal, (void *)(intptr_t)ch);
263 }
264
265 static void *
uim_scm_make_char_internal(intptr_t ch)266 uim_scm_make_char_internal(intptr_t ch)
267 {
268 return (void *)SCM_MAKE_CHAR((scm_ichar_t)ch);
269 }
270
271 char *
uim_scm_c_str(uim_lisp str)272 uim_scm_c_str(uim_lisp str)
273 {
274 const char *c_str;
275
276 assert(uim_scm_gc_any_contextp());
277 assert(uim_scm_gc_protectedp(str));
278
279 c_str = uim_scm_refer_c_str(str);
280
281 return (c_str) ? scm_strdup(c_str) : NULL;
282 }
283
284 const char *
uim_scm_refer_c_str(uim_lisp str)285 uim_scm_refer_c_str(uim_lisp str)
286 {
287 assert(uim_scm_gc_any_contextp());
288 assert(uim_scm_gc_protectedp(str));
289
290 return uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_refer_c_str_internal, (void *)str);
291 }
292
293 static const char *
uim_scm_refer_c_str_internal(void * uim_lisp_str)294 uim_scm_refer_c_str_internal(void *uim_lisp_str)
295 {
296 char *c_str;
297 uim_lisp str;
298
299 str = (uim_lisp)uim_lisp_str;
300
301 if (SCM_STRINGP((ScmObj)str)) {
302 c_str = SCM_STRING_STR((ScmObj)str);
303 } else if (SCM_SYMBOLP((ScmObj)str)) {
304 c_str = SCM_SYMBOL_NAME((ScmObj)str);
305 } else {
306 uim_scm_error_obj("uim_scm_refer_c_str: string or symbol required but got ",
307 str);
308 SCM_NOTREACHED;
309 }
310
311 return c_str;
312 }
313
314 uim_lisp
uim_scm_make_str(const char * str)315 uim_scm_make_str(const char *str)
316 {
317 assert(uim_scm_gc_any_contextp());
318 assert(str);
319
320 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_make_str_internal, (void *)str);
321 }
322
323 static void *
uim_scm_make_str_internal(const char * str)324 uim_scm_make_str_internal(const char *str)
325 {
326 return (void *)SCM_MAKE_STRING_COPYING(str, SCM_STRLEN_UNKNOWN);
327 }
328
329 uim_lisp
uim_scm_make_str_directly(char * str)330 uim_scm_make_str_directly(char *str)
331 {
332 assert(uim_scm_gc_any_contextp());
333 assert(str);
334
335 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_make_str_directly_internal, (void *)str);
336 }
337
338 static void *
uim_scm_make_str_directly_internal(char * str)339 uim_scm_make_str_directly_internal(char *str)
340 {
341 return (void *)SCM_MAKE_STRING(str, SCM_STRLEN_UNKNOWN);
342 }
343
344 char *
uim_scm_c_symbol(uim_lisp symbol)345 uim_scm_c_symbol(uim_lisp symbol)
346 {
347 assert(uim_scm_gc_any_contextp());
348 assert(uim_scm_gc_protectedp(symbol));
349
350 return scm_strdup((char *)SCM_SYMBOL_NAME((ScmObj)symbol));
351 }
352
353 uim_lisp
uim_scm_make_symbol(const char * name)354 uim_scm_make_symbol(const char *name)
355 {
356 assert(uim_scm_gc_any_contextp());
357 assert(name);
358
359 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_make_symbol_internal, (void *)name);
360 }
361
362 static void *
uim_scm_make_symbol_internal(const char * name)363 uim_scm_make_symbol_internal(const char *name)
364 {
365 return (void *)scm_intern(name);
366 }
367
368 void *
uim_scm_c_ptr(uim_lisp ptr)369 uim_scm_c_ptr(uim_lisp ptr)
370 {
371 assert(uim_scm_gc_any_contextp());
372 assert(uim_scm_gc_protectedp(ptr));
373
374 if (!SCM_C_POINTERP((ScmObj)ptr))
375 uim_scm_error_obj("uim_scm_c_ptr: C pointer required but got ", ptr);
376
377 return SCM_C_POINTER_VALUE((ScmObj)ptr);
378 }
379
380 void
uim_scm_nullify_c_ptr(uim_lisp ptr)381 uim_scm_nullify_c_ptr(uim_lisp ptr)
382 {
383 assert(uim_scm_gc_any_contextp());
384 assert(uim_scm_gc_protectedp(ptr));
385
386 if (!SCM_C_POINTERP((ScmObj)ptr))
387 uim_scm_error_obj("uim_scm_nullify_c_ptr: C pointer required but got ",
388 ptr);
389
390 SCM_C_POINTER_SET_VALUE((ScmObj)ptr, NULL);
391 }
392
393 uim_lisp
uim_scm_make_ptr(void * ptr)394 uim_scm_make_ptr(void *ptr)
395 {
396 assert(uim_scm_gc_any_contextp());
397
398 return (uim_lisp)uim_scm_call_with_gc_ready_stack(uim_scm_make_ptr_internal,
399 ptr);
400 }
401
402 static void *
uim_scm_make_ptr_internal(void * ptr)403 uim_scm_make_ptr_internal(void *ptr)
404 {
405 return (void *)SCM_MAKE_C_POINTER(ptr);
406 }
407
408 uim_func_ptr
uim_scm_c_func_ptr(uim_lisp func_ptr)409 uim_scm_c_func_ptr(uim_lisp func_ptr)
410 {
411 assert(uim_scm_gc_any_contextp());
412 assert(uim_scm_gc_protectedp(func_ptr));
413
414 if (!SCM_C_FUNCPOINTERP((ScmObj)func_ptr))
415 uim_scm_error_obj("uim_scm_c_func_ptr: C function pointer required but got ", func_ptr);
416
417 return SCM_C_FUNCPOINTER_VALUE((ScmObj)func_ptr);
418 }
419
420 uim_lisp
uim_scm_make_func_ptr(uim_func_ptr func_ptr)421 uim_scm_make_func_ptr(uim_func_ptr func_ptr)
422 {
423 assert(uim_scm_gc_any_contextp());
424
425 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_make_func_ptr_internal, (void *)(uintptr_t)func_ptr);
426 }
427
428 static void *
uim_scm_make_func_ptr_internal(uim_func_ptr func_ptr)429 uim_scm_make_func_ptr_internal(uim_func_ptr func_ptr)
430 {
431 return (void *)SCM_MAKE_C_FUNCPOINTER((ScmCFunc)func_ptr);
432 }
433
434 void
uim_scm_gc_protect(uim_lisp * location)435 uim_scm_gc_protect(uim_lisp *location)
436 {
437 assert(uim_scm_gc_any_contextp());
438 assert(location);
439
440 scm_gc_protect((ScmObj *)location);
441 }
442
443 void
uim_scm_gc_unprotect(uim_lisp * location)444 uim_scm_gc_unprotect(uim_lisp *location)
445 {
446 assert(uim_scm_gc_any_contextp());
447 assert(location);
448
449 scm_gc_unprotect((ScmObj *)location);
450 }
451
452 void *
uim_scm_call_with_gc_ready_stack(uim_gc_gate_func_ptr func,void * arg)453 uim_scm_call_with_gc_ready_stack(uim_gc_gate_func_ptr func, void *arg)
454 {
455 assert(uim_scm_gc_any_contextp());
456 assert(func);
457
458 return scm_call_with_gc_ready_stack(func, arg);
459 }
460
461 uim_bool
uim_scm_gc_protectedp(uim_lisp obj)462 uim_scm_gc_protectedp(uim_lisp obj)
463 {
464 assert(uim_scm_gc_any_contextp());
465
466 return scm_gc_protectedp((ScmObj)obj);
467 }
468
469 uim_bool
uim_scm_gc_protected_contextp(void)470 uim_scm_gc_protected_contextp(void)
471 {
472 return (initialized && scm_gc_protected_contextp());
473 }
474
475 uim_bool
uim_scm_is_initialized(void)476 uim_scm_is_initialized(void)
477 {
478 return initialized;
479 }
480
481 void
uim_scm_set_lib_path(const char * path)482 uim_scm_set_lib_path(const char *path)
483 {
484 assert(uim_scm_gc_any_contextp());
485
486 scm_set_lib_path(path);
487 }
488
489 /* temporary solution for getting an value from Scheme world */
490 uim_lisp
uim_scm_symbol_value(const char * symbol_str)491 uim_scm_symbol_value(const char *symbol_str)
492 {
493 assert(uim_scm_gc_any_contextp());
494 assert(symbol_str);
495
496 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_symbol_value_internal, (void *)symbol_str);
497 }
498
499 static void *
uim_scm_symbol_value_internal(const char * symbol_str)500 uim_scm_symbol_value_internal(const char *symbol_str)
501 {
502 ScmObj symbol;
503
504 symbol = scm_intern(symbol_str);
505 if (SCM_TRUEP(scm_p_symbol_boundp(symbol, SCM_NULL))) {
506 return (void *)(uim_lisp)scm_p_symbol_value(symbol);
507 } else {
508 return (void *)uim_scm_f();
509 }
510 }
511
512 uim_bool
uim_scm_symbol_value_bool(const char * symbol_str)513 uim_scm_symbol_value_bool(const char *symbol_str)
514 {
515 uim_bool val;
516
517 assert(uim_scm_gc_any_contextp());
518 assert(symbol_str);
519
520 val = uim_scm_c_bool(uim_scm_symbol_value(symbol_str));
521
522 return val;
523 }
524
525 long
uim_scm_symbol_value_int(const char * symbol_str)526 uim_scm_symbol_value_int(const char *symbol_str)
527 {
528 assert(uim_scm_gc_any_contextp());
529 assert(symbol_str);
530
531 return (long)(intptr_t)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_symbol_value_int_internal, (void *)symbol_str);
532 }
533
534 static void *
uim_scm_symbol_value_int_internal(const char * symbol_str)535 uim_scm_symbol_value_int_internal(const char *symbol_str)
536 {
537 uim_lisp val_;
538 long val;
539
540 val_ = uim_scm_symbol_value(symbol_str);
541 val = (uim_scm_truep(val_)) ? uim_scm_c_int(val_) : 0;
542
543 return (void *)(intptr_t)val;
544 }
545
546 char *
uim_scm_symbol_value_str(const char * symbol_str)547 uim_scm_symbol_value_str(const char *symbol_str)
548 {
549 assert(uim_scm_gc_any_contextp());
550 assert(symbol_str);
551
552 return uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_symbol_value_str_internal, (void *)symbol_str);
553 }
554
555 static char *
uim_scm_symbol_value_str_internal(const char * symbol_str)556 uim_scm_symbol_value_str_internal(const char *symbol_str)
557 {
558 uim_lisp val_;
559 char *val;
560
561 val_ = uim_scm_symbol_value(symbol_str);
562 val = (uim_scm_truep(val_)) ? uim_scm_c_str(val_) : NULL;
563
564 return val;
565 }
566
567 uim_bool
uim_scm_load_file(const char * fn)568 uim_scm_load_file(const char *fn)
569 {
570 uim_lisp ok;
571
572 assert(uim_scm_gc_any_contextp());
573 assert(fn);
574
575 /* (guard (err (else #f)) (load "<fn>")) */
576 protected = ok = uim_scm_callf_with_guard(uim_scm_f(), "load", "s", fn);
577
578 return uim_scm_c_bool(ok);
579 }
580
581 uim_lisp
uim_scm_t(void)582 uim_scm_t(void)
583 {
584 assert(uim_scm_gc_any_contextp());
585
586 return (uim_lisp)SCM_TRUE;
587 }
588
589 uim_lisp
uim_scm_f(void)590 uim_scm_f(void)
591 {
592 assert(uim_scm_gc_any_contextp());
593
594 return (uim_lisp)SCM_FALSE;
595 }
596
597 uim_lisp
uim_scm_null(void)598 uim_scm_null(void)
599 {
600 assert(uim_scm_gc_any_contextp());
601
602 return (uim_lisp)SCM_NULL;
603 }
604
605 uim_lisp
uim_scm_eof(void)606 uim_scm_eof(void)
607 {
608 assert(uim_scm_gc_any_contextp());
609
610 return (uim_lisp)SCM_EOF;
611 }
612
613 uim_lisp
uim_scm_quote(uim_lisp obj)614 uim_scm_quote(uim_lisp obj)
615 {
616 assert(uim_scm_gc_any_contextp());
617 assert(uim_scm_gc_protectedp(obj));
618
619 return (uim_lisp)uim_scm_call_with_gc_ready_stack(uim_scm_quote_internal,
620 (void *)obj);
621 }
622
623 static void *
uim_scm_quote_internal(void * obj)624 uim_scm_quote_internal(void *obj)
625 {
626 return (void *)SCM_LIST_2(SCM_SYM_QUOTE, (ScmObj)obj);
627 }
628
629 uim_lisp
uim_scm_list1(uim_lisp elm1)630 uim_scm_list1(uim_lisp elm1)
631 {
632 assert(uim_scm_gc_any_contextp());
633 assert(uim_scm_gc_protectedp(elm1));
634
635 return uim_scm_cons(elm1, uim_scm_null());
636 }
637
638 uim_lisp
uim_scm_list2(uim_lisp elm1,uim_lisp elm2)639 uim_scm_list2(uim_lisp elm1, uim_lisp elm2)
640 {
641 assert(uim_scm_gc_any_contextp());
642 assert(uim_scm_gc_protectedp(elm1));
643 assert(uim_scm_gc_protectedp(elm2));
644
645 return uim_scm_cons(elm1, uim_scm_list1(elm2));
646 }
647
648 uim_lisp
uim_scm_list3(uim_lisp elm1,uim_lisp elm2,uim_lisp elm3)649 uim_scm_list3(uim_lisp elm1, uim_lisp elm2, uim_lisp elm3)
650 {
651 assert(uim_scm_gc_any_contextp());
652 assert(uim_scm_gc_protectedp(elm1));
653 assert(uim_scm_gc_protectedp(elm2));
654 assert(uim_scm_gc_protectedp(elm3));
655
656 return uim_scm_cons(elm1, uim_scm_list2(elm2, elm3));
657 }
658
659 uim_lisp
uim_scm_list4(uim_lisp elm1,uim_lisp elm2,uim_lisp elm3,uim_lisp elm4)660 uim_scm_list4(uim_lisp elm1, uim_lisp elm2, uim_lisp elm3, uim_lisp elm4)
661 {
662 assert(uim_scm_gc_any_contextp());
663 assert(uim_scm_gc_protectedp(elm1));
664 assert(uim_scm_gc_protectedp(elm2));
665 assert(uim_scm_gc_protectedp(elm3));
666 assert(uim_scm_gc_protectedp(elm4));
667
668 return uim_scm_cons(elm1, uim_scm_list3(elm2, elm3, elm4));
669 }
670
671 uim_lisp
uim_scm_list5(uim_lisp elm1,uim_lisp elm2,uim_lisp elm3,uim_lisp elm4,uim_lisp elm5)672 uim_scm_list5(uim_lisp elm1, uim_lisp elm2, uim_lisp elm3, uim_lisp elm4,
673 uim_lisp elm5)
674 {
675 assert(uim_scm_gc_any_contextp());
676 assert(uim_scm_gc_protectedp(elm1));
677 assert(uim_scm_gc_protectedp(elm2));
678 assert(uim_scm_gc_protectedp(elm3));
679 assert(uim_scm_gc_protectedp(elm4));
680 assert(uim_scm_gc_protectedp(elm5));
681
682 return uim_scm_cons(elm1, uim_scm_list4(elm2, elm3, elm4, elm5));
683 }
684
685 /* Pass through uim_lisp if (conv == NULL). */
686 uim_lisp
uim_scm_array2list(void ** ary,size_t len,uim_lisp (* conv)(void *))687 uim_scm_array2list(void **ary, size_t len, uim_lisp (*conv)(void *))
688 {
689 struct array2list_args args;
690
691 assert(uim_scm_gc_any_contextp());
692 assert(len < SCM_INT_T_MAX);
693 assert(conv || !conv);
694
695 args.ary = ary;
696 args.len = len;
697 args.conv = conv;
698
699 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_array2list_internal, &args);
700 }
701
702 static void *
uim_scm_array2list_internal(struct array2list_args * args)703 uim_scm_array2list_internal(struct array2list_args *args)
704 {
705 return (void *)scm_array2list(args->ary, args->len,
706 (ScmObj (*)(void *))args->conv);
707 }
708
709 /* Only accepts proper list. */
710 void **
uim_scm_list2array(uim_lisp lst,size_t * len,void * (* conv)(uim_lisp))711 uim_scm_list2array(uim_lisp lst, size_t *len, void *(*conv)(uim_lisp))
712 {
713 struct list2array_args args;
714
715 assert(uim_scm_gc_any_contextp());
716 assert(uim_scm_gc_protectedp(lst));
717 assert(conv || !conv);
718
719 args.lst = lst;
720 args.len = len;
721 args.conv = conv;
722
723 return (void **)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_list2array_internal, &args);
724 }
725
726 static void *
uim_scm_list2array_internal(struct list2array_args * args)727 uim_scm_list2array_internal(struct list2array_args *args)
728 {
729 return (void *)scm_list2array((ScmObj)args->lst, args->len,
730 (void *(*)(ScmObj))args->conv);
731 }
732
733 /* Pass through uim_lisp if (conv == NULL). */
734 uim_lisp
uim_scm_array2vector(void ** ary,size_t len,uim_lisp (* conv)(void *))735 uim_scm_array2vector(void **ary, size_t len, uim_lisp (*conv)(void *))
736 {
737 struct array2vector_args args;
738
739 assert(uim_scm_gc_any_contextp());
740 assert(ary);
741 assert(len < SCM_INT_T_MAX);
742 assert(conv || !conv);
743
744 args.ary = ary;
745 args.len = len;
746 args.conv = conv;
747
748 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_array2vector_internal, &args);
749 }
750
751 static void *
uim_scm_array2vector_internal(struct array2vector_args * args)752 uim_scm_array2vector_internal(struct array2vector_args *args)
753 {
754 ScmObj *vec;
755 size_t i;
756
757 vec = scm_malloc(args->len * sizeof(ScmObj));
758 for (i = 0; i < args->len; i++)
759 vec[i] = (ScmObj)args->conv(args->ary[i]);
760
761 return (void *)(uintptr_t)SCM_MAKE_VECTOR(vec, args->len);
762 }
763
764 /* Only accepts proper list. */
765 void **
uim_scm_vector2array(uim_lisp vec,size_t * len,void * (* conv)(uim_lisp))766 uim_scm_vector2array(uim_lisp vec, size_t *len, void *(*conv)(uim_lisp))
767 {
768 struct vector2array_args args;
769
770 assert(uim_scm_gc_any_contextp());
771 assert(uim_scm_gc_protectedp(vec));
772 assert(len);
773 assert(conv || !conv);
774
775 UIM_SCM_ENSURE_TYPE(vector, vec);
776
777 args.vec = vec;
778 args.len = len;
779 args.conv = conv;
780
781 return (void **)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_vector2array_internal, &args);
782 }
783
784 static void *
uim_scm_vector2array_internal(struct vector2array_args * args)785 uim_scm_vector2array_internal(struct vector2array_args *args)
786 {
787 void **ary;
788 ScmObj vec_, *vec;
789 size_t len, i;
790
791 vec_ = (ScmObj)args->vec;
792 vec = SCM_VECTOR_VEC(vec_);
793 len = (size_t)SCM_VECTOR_LEN(vec_);
794 *args->len = len;
795
796 ary = scm_malloc(len * sizeof(void *));
797 for (i = 0; i < len; i++)
798 ary[i] = args->conv((uim_lisp)vec[i]);
799
800 return ary;
801 }
802
803 /* (if obj #t #f) */
804 uim_bool
uim_scm_truep(uim_lisp obj)805 uim_scm_truep(uim_lisp obj)
806 {
807 assert(uim_scm_gc_any_contextp());
808
809 return (SCM_TRUEP((ScmObj)obj));
810 }
811
812 uim_bool
uim_scm_falsep(uim_lisp obj)813 uim_scm_falsep(uim_lisp obj)
814 {
815 assert(uim_scm_gc_any_contextp());
816
817 return (SCM_FALSEP((ScmObj)obj));
818 }
819
820 uim_bool
uim_scm_nullp(uim_lisp obj)821 uim_scm_nullp(uim_lisp obj)
822 {
823 assert(uim_scm_gc_any_contextp());
824
825 return (SCM_NULLP((ScmObj)obj));
826 }
827
828 uim_bool
uim_scm_consp(uim_lisp obj)829 uim_scm_consp(uim_lisp obj)
830 {
831 assert(uim_scm_gc_any_contextp());
832
833 return (SCM_CONSP((ScmObj)obj));
834 }
835
836 uim_bool
uim_scm_listp(uim_lisp obj)837 uim_scm_listp(uim_lisp obj)
838 {
839 assert(uim_scm_gc_any_contextp());
840
841 /* does not detect circular list */
842 return (SCM_NULLP((ScmObj)obj) || SCM_CONSP((ScmObj)obj));
843 }
844
845 uim_bool
uim_scm_intp(uim_lisp obj)846 uim_scm_intp(uim_lisp obj)
847 {
848 assert(uim_scm_gc_any_contextp());
849
850 return (SCM_INTP((ScmObj)obj));
851 }
852
853 uim_bool
uim_scm_charp(uim_lisp obj)854 uim_scm_charp(uim_lisp obj)
855 {
856 assert(uim_scm_gc_any_contextp());
857
858 return (SCM_CHARP((ScmObj)obj));
859 }
860
861 uim_bool
uim_scm_vectorp(uim_lisp obj)862 uim_scm_vectorp(uim_lisp obj)
863 {
864 assert(uim_scm_gc_any_contextp());
865
866 return (SCM_VECTORP((ScmObj)obj));
867 }
868
869 uim_bool
uim_scm_strp(uim_lisp obj)870 uim_scm_strp(uim_lisp obj)
871 {
872 assert(uim_scm_gc_any_contextp());
873
874 return (SCM_STRINGP((ScmObj)obj));
875 }
876
877 uim_bool
uim_scm_symbolp(uim_lisp obj)878 uim_scm_symbolp(uim_lisp obj)
879 {
880 assert(uim_scm_gc_any_contextp());
881
882 return (SCM_SYMBOLP((ScmObj)obj));
883 }
884
885 uim_bool
uim_scm_ptrp(uim_lisp obj)886 uim_scm_ptrp(uim_lisp obj)
887 {
888 assert(uim_scm_gc_any_contextp());
889
890 return (SCM_C_POINTERP((ScmObj)obj));
891 }
892
893 uim_bool
uim_scm_func_ptrp(uim_lisp obj)894 uim_scm_func_ptrp(uim_lisp obj)
895 {
896 assert(uim_scm_gc_any_contextp());
897
898 return (SCM_C_FUNCPOINTERP((ScmObj)obj));
899 }
900
901 uim_bool
uim_scm_eq(uim_lisp a,uim_lisp b)902 uim_scm_eq(uim_lisp a, uim_lisp b)
903 {
904 assert(uim_scm_gc_any_contextp());
905 assert(uim_scm_gc_protectedp(a));
906 assert(uim_scm_gc_protectedp(b));
907
908 return (SCM_EQ((ScmObj)a, (ScmObj)b));
909 }
910
911 uim_lisp
uim_scm_eval(uim_lisp obj)912 uim_scm_eval(uim_lisp obj)
913 {
914 assert(uim_scm_gc_any_contextp());
915 assert(uim_scm_gc_protectedp(obj));
916
917 return (uim_lisp)uim_scm_call_with_gc_ready_stack(uim_scm_eval_internal,
918 (void *)obj);
919 }
920
921 static void *
uim_scm_eval_internal(void * uim_lisp_obj)922 uim_scm_eval_internal(void *uim_lisp_obj)
923 {
924 uim_lisp obj;
925
926 obj = (uim_lisp)uim_lisp_obj;
927
928 return (void *)scm_p_eval((ScmObj)obj, SCM_NULL);
929 }
930
931 uim_lisp
uim_scm_eval_c_string(const char * str)932 uim_scm_eval_c_string(const char *str)
933 {
934 assert(uim_scm_gc_any_contextp());
935
936 return (uim_lisp)scm_eval_c_string(str);
937 }
938
939 uim_lisp
uim_scm_call(uim_lisp proc,uim_lisp args)940 uim_scm_call(uim_lisp proc, uim_lisp args)
941 {
942 struct call_args _args;
943
944 assert(uim_scm_gc_any_contextp());
945 assert(uim_scm_gc_protectedp(proc));
946 assert(uim_scm_gc_protectedp(args));
947
948 _args.proc = proc;
949 _args.args = args;
950 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_call_internal, &_args);
951 }
952
953 static void *
uim_scm_call_internal(struct call_args * args)954 uim_scm_call_internal(struct call_args *args)
955 {
956 if (uim_scm_symbolp(args->proc))
957 args->proc = uim_scm_eval(args->proc);
958
959 return (void *)scm_call((ScmObj)args->proc, (ScmObj)args->args);
960 }
961
962 uim_lisp
uim_scm_call_with_guard(uim_lisp failed,uim_lisp proc,uim_lisp args)963 uim_scm_call_with_guard(uim_lisp failed, uim_lisp proc, uim_lisp args)
964 {
965 struct call_args _args;
966
967 assert(uim_scm_gc_any_contextp());
968 assert(uim_scm_gc_protectedp(failed));
969 assert(uim_scm_gc_protectedp(proc));
970 assert(uim_scm_gc_protectedp(args));
971
972 _args.failed = failed;
973 _args.proc = proc;
974 _args.args = args;
975 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_call_with_guard_internal, &_args);
976 }
977
978 static void *
uim_scm_call_with_guard_internal(struct call_args * args)979 uim_scm_call_with_guard_internal(struct call_args *args)
980 {
981 uim_lisp form;
982
983 /* (guard (err (else '<failed>)) (apply <proc> '<args>)) */
984 form = uim_scm_list3(uim_scm_make_symbol("guard"),
985 uim_scm_list2(uim_scm_make_symbol("err"),
986 uim_scm_list2(uim_scm_make_symbol("else"),
987 uim_scm_quote(args->failed))),
988 uim_scm_list3(uim_scm_make_symbol("apply"),
989 args->proc,
990 uim_scm_quote(args->args)));
991
992 return (void *)uim_scm_eval(form);
993 }
994
995 uim_lisp
uim_scm_callf(const char * proc,const char * args_fmt,...)996 uim_scm_callf(const char *proc, const char *args_fmt, ...)
997 {
998 uim_lisp ret;
999 struct callf_args args;
1000
1001 assert(uim_scm_gc_any_contextp());
1002 assert(proc);
1003 assert(args_fmt);
1004
1005 va_start(args.args, args_fmt);
1006
1007 args.proc = proc;
1008 args.args_fmt = args_fmt;
1009 args.with_guard = UIM_FALSE;
1010 ret = (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_callf_internal, &args);
1011
1012 va_end(args.args);
1013
1014 return ret;
1015 }
1016
1017 static void *
uim_scm_callf_internal(struct callf_args * args)1018 uim_scm_callf_internal(struct callf_args *args)
1019 {
1020 ScmObj proc, scm_args, arg;
1021 ScmQueue argq;
1022 const char *fmtp;
1023
1024 proc = scm_eval(scm_intern(args->proc), SCM_INTERACTION_ENV);
1025 scm_args = SCM_NULL;
1026 SCM_QUEUE_POINT_TO(argq, scm_args);
1027 for (fmtp = args->args_fmt; *fmtp; fmtp++) {
1028 switch (*fmtp) {
1029 case 'b':
1030 arg = SCM_MAKE_BOOL(va_arg(args->args, int));
1031 break;
1032
1033 case 'i':
1034 arg = SCM_MAKE_INT(va_arg(args->args, int));
1035 break;
1036
1037 case 'l':
1038 arg = SCM_MAKE_INT(va_arg(args->args, long));
1039 break;
1040
1041 case 'j':
1042 arg = SCM_MAKE_INT(va_arg(args->args, intmax_t));
1043 break;
1044
1045 case 'c':
1046 arg = SCM_MAKE_CHAR(va_arg(args->args, int));
1047 break;
1048
1049 case 's':
1050 arg = SCM_MAKE_STRING_COPYING(va_arg(args->args, const char *),
1051 SCM_STRLEN_UNKNOWN);
1052 break;
1053
1054 case 'y':
1055 arg = scm_intern(va_arg(args->args, const char *));
1056 break;
1057
1058 case 'p':
1059 arg = SCM_MAKE_C_POINTER(va_arg(args->args, void *));
1060 break;
1061
1062 case 'f':
1063 arg = SCM_MAKE_C_FUNCPOINTER(va_arg(args->args, ScmCFunc));
1064 break;
1065
1066 case 'o':
1067 arg = (ScmObj)va_arg(args->args, uim_lisp);
1068 assert(scm_gc_protectedp(arg));
1069 break;
1070
1071 case 'v':
1072 arg = scm_symbol_value(scm_intern(va_arg(args->args, const char *)),
1073 SCM_INTERACTION_ENV);
1074 break;
1075
1076 default:
1077 SCM_NOTREACHED;
1078 }
1079 SCM_QUEUE_ADD(argq, arg);
1080 }
1081
1082 if (args->with_guard)
1083 return (void *)uim_scm_call_with_guard(args->failed,
1084 (uim_lisp)proc, (uim_lisp)scm_args);
1085 else
1086 return (void *)(uim_lisp)scm_call(proc, scm_args);
1087 }
1088
1089 uim_lisp
uim_scm_callf_with_guard(uim_lisp failed,const char * proc,const char * args_fmt,...)1090 uim_scm_callf_with_guard(uim_lisp failed,
1091 const char *proc, const char *args_fmt, ...)
1092 {
1093 uim_lisp ret;
1094 struct callf_args args;
1095
1096 assert(uim_scm_gc_any_contextp());
1097 assert(uim_scm_gc_protectedp(failed));
1098 assert(proc);
1099 assert(args_fmt);
1100
1101 va_start(args.args, args_fmt);
1102
1103 args.proc = proc;
1104 args.args_fmt = args_fmt;
1105 args.with_guard = UIM_TRUE;
1106 args.failed = failed;
1107 ret = (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_callf_internal, &args);
1108
1109 va_end(args.args);
1110
1111 return ret;
1112 }
1113
1114 uim_lisp
uim_scm_car(uim_lisp pair)1115 uim_scm_car(uim_lisp pair)
1116 {
1117 assert(uim_scm_gc_protected_contextp());
1118
1119 return (uim_lisp)scm_p_car((ScmObj)pair);
1120 }
1121
1122 uim_lisp
uim_scm_cdr(uim_lisp pair)1123 uim_scm_cdr(uim_lisp pair)
1124 {
1125 assert(uim_scm_gc_protected_contextp());
1126
1127 return (uim_lisp)scm_p_cdr((ScmObj)pair);
1128 }
1129
1130 void
uim_scm_set_car(uim_lisp pair,uim_lisp car)1131 uim_scm_set_car(uim_lisp pair, uim_lisp car)
1132 {
1133 assert(uim_scm_gc_protected_contextp());
1134
1135 scm_p_set_carx((ScmObj)pair, (ScmObj)car);
1136 }
1137
1138 void
uim_scm_set_cdr(uim_lisp pair,uim_lisp cdr)1139 uim_scm_set_cdr(uim_lisp pair, uim_lisp cdr)
1140 {
1141 assert(uim_scm_gc_protected_contextp());
1142
1143 scm_p_set_cdrx((ScmObj)pair, (ScmObj)cdr);
1144 }
1145
1146 uim_lisp
uim_scm_cons(uim_lisp car,uim_lisp cdr)1147 uim_scm_cons(uim_lisp car, uim_lisp cdr)
1148 {
1149 struct cons_args args;
1150
1151 assert(uim_scm_gc_any_contextp());
1152 assert(uim_scm_gc_protectedp(car));
1153 assert(uim_scm_gc_protectedp(cdr));
1154
1155 args.car = car;
1156 args.cdr = cdr;
1157 return (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_cons_internal, &args);
1158 }
1159
1160 static void *
uim_scm_cons_internal(struct cons_args * args)1161 uim_scm_cons_internal(struct cons_args *args)
1162 {
1163 return (void *)SCM_CONS((ScmObj)args->car, (ScmObj)args->cdr);
1164 }
1165
1166 long
uim_scm_length(uim_lisp lst)1167 uim_scm_length(uim_lisp lst)
1168 {
1169 uim_lisp len;
1170
1171 assert(uim_scm_gc_protected_contextp());
1172 assert(uim_scm_gc_protectedp(lst));
1173
1174 protected = len = (uim_lisp)scm_p_length((ScmObj)lst);
1175 return uim_scm_c_int(len);
1176 }
1177
1178 uim_lisp
uim_scm_vector_ref(uim_lisp vec,long i)1179 uim_scm_vector_ref(uim_lisp vec, long i)
1180 {
1181 assert(uim_scm_gc_protected_contextp());
1182 assert(uim_scm_gc_protectedp(vec));
1183
1184 return (uim_lisp)scm_p_vector_ref((ScmObj)vec, SCM_MAKE_INT(i));
1185 }
1186
1187 void
uim_scm_vector_set(uim_lisp vec,long i,uim_lisp elm)1188 uim_scm_vector_set(uim_lisp vec, long i, uim_lisp elm)
1189 {
1190 assert(uim_scm_gc_protected_contextp());
1191 assert(uim_scm_gc_protectedp(vec));
1192 assert(uim_scm_gc_protectedp(elm));
1193
1194 scm_p_vector_setx((ScmObj)vec, SCM_MAKE_INT(i), (ScmObj)elm);
1195 }
1196
1197 long
uim_scm_vector_length(uim_lisp vec)1198 uim_scm_vector_length(uim_lisp vec)
1199 {
1200 assert(uim_scm_gc_protected_contextp());
1201 assert(uim_scm_gc_protectedp(vec));
1202
1203 /* To add type check for vec, SCM_VECTOR_LEN() is not directly used. */
1204 return uim_scm_c_int((uim_lisp)scm_p_vector_length((ScmObj)vec));
1205 }
1206
1207 uim_bool
uim_scm_require_file(const char * fn)1208 uim_scm_require_file(const char *fn)
1209 {
1210 uim_lisp ok;
1211
1212 assert(uim_scm_gc_any_contextp());
1213 assert(fn);
1214
1215 /* (guard (err (else #f)) (require "<fn>")) */
1216 protected = ok = uim_scm_callf_with_guard(uim_scm_f(), "require", "s", fn);
1217
1218 return uim_scm_c_bool(ok);
1219 }
1220
1221 void
uim_scm_init_proc0(const char * name,uim_lisp (* func)(void))1222 uim_scm_init_proc0(const char *name, uim_lisp (*func)(void))
1223 {
1224 assert(uim_scm_gc_protected_contextp());
1225 assert(name);
1226 assert(func);
1227
1228 scm_register_func(name, (scm_procedure_fixed_0)func, SCM_PROCEDURE_FIXED_0);
1229 }
1230
1231 void
uim_scm_init_proc1(const char * name,uim_lisp (* func)(uim_lisp))1232 uim_scm_init_proc1(const char *name, uim_lisp (*func)(uim_lisp))
1233 {
1234 assert(uim_scm_gc_protected_contextp());
1235 assert(name);
1236 assert(func);
1237
1238 scm_register_func(name, (scm_procedure_fixed_1)func, SCM_PROCEDURE_FIXED_1);
1239 }
1240
1241 void
uim_scm_init_proc2(const char * name,uim_lisp (* func)(uim_lisp,uim_lisp))1242 uim_scm_init_proc2(const char *name, uim_lisp (*func)(uim_lisp, uim_lisp))
1243 {
1244 assert(uim_scm_gc_protected_contextp());
1245 assert(name);
1246 assert(func);
1247
1248 scm_register_func(name, (scm_procedure_fixed_2)func, SCM_PROCEDURE_FIXED_2);
1249 }
1250
1251 void
uim_scm_init_proc3(const char * name,uim_lisp (* func)(uim_lisp,uim_lisp,uim_lisp))1252 uim_scm_init_proc3(const char *name,
1253 uim_lisp (*func)(uim_lisp, uim_lisp, uim_lisp))
1254 {
1255 assert(uim_scm_gc_protected_contextp());
1256 assert(name);
1257 assert(func);
1258
1259 scm_register_func(name, (scm_procedure_fixed_3)func, SCM_PROCEDURE_FIXED_3);
1260 }
1261
1262 void
uim_scm_init_proc4(const char * name,uim_lisp (* func)(uim_lisp,uim_lisp,uim_lisp,uim_lisp))1263 uim_scm_init_proc4(const char *name,
1264 uim_lisp (*func)(uim_lisp, uim_lisp, uim_lisp, uim_lisp))
1265 {
1266 assert(uim_scm_gc_protected_contextp());
1267 assert(name);
1268 assert(func);
1269
1270 scm_register_func(name, (scm_procedure_fixed_4)func, SCM_PROCEDURE_FIXED_4);
1271 }
1272
1273 void
uim_scm_init_proc5(const char * name,uim_lisp (* func)(uim_lisp,uim_lisp,uim_lisp,uim_lisp,uim_lisp))1274 uim_scm_init_proc5(const char *name,
1275 uim_lisp (*func)(uim_lisp, uim_lisp, uim_lisp, uim_lisp,
1276 uim_lisp))
1277 {
1278 assert(uim_scm_gc_protected_contextp());
1279 assert(name);
1280 assert(func);
1281
1282 scm_register_func(name, (scm_procedure_fixed_5)func, SCM_PROCEDURE_FIXED_5);
1283 }
1284
1285 void
uim_scm_init(const char * system_load_path)1286 uim_scm_init(const char *system_load_path)
1287 {
1288 ScmStorageConf storage_conf;
1289 char **argp, *argv[8];
1290
1291 if (initialized)
1292 return;
1293
1294 argp = argv;
1295 *argp++ = "dummy"; /* command name */
1296 #if SCM_USE_MULTIBYTE_CHAR
1297 /*
1298 * Set the raw unibyte codec which accepts all (multi)byte sequence
1299 * although it slashes a multibyte character on Scheme-level
1300 * character processing. Since current uim implementation treats a
1301 * multibyte character as string, it is not a problem. The name
1302 * "ISO-8859-1" is a dummy name for the codec.
1303 */
1304 *argp++ = "-C";
1305 *argp++ = "ISO-8859-1";
1306 #endif
1307 if (system_load_path) {
1308 *argp++ = "--system-load-path";
1309 *argp++ = (char *)system_load_path; /* safe */
1310 }
1311 *argp++ = NULL;
1312
1313 /* 128KB/heap, max 0.99GB on 32-bit systems. Since maximum length of list can
1314 * be represented by a Scheme integer, SCM_INT_MAX limits the number of cons
1315 * cells. */
1316 storage_conf.heap_size = 16384;
1317 storage_conf.heap_alloc_threshold = 16384;
1318 storage_conf.n_heaps_max = SCM_INT_MAX / storage_conf.heap_size;
1319 storage_conf.n_heaps_init = 1;
1320 storage_conf.symbol_hash_size = 1024;
1321 scm_initialize(&storage_conf, (const char *const *)&argv);
1322 initialized = UIM_TRUE; /* init here for uim_scm_gc_protect() */
1323
1324 protected = (uim_lisp)SCM_FALSE;
1325 uim_scm_gc_protect(&protected);
1326
1327 #ifdef DEBUG_SCM
1328 /* required by test-im.scm */
1329 uim_scm_callf("provide", "s", "debug");
1330 #endif
1331
1332 scm_require_module("srfi-34");
1333 }
1334
1335 void
uim_scm_quit(void)1336 uim_scm_quit(void)
1337 {
1338 if (!initialized)
1339 return;
1340
1341 scm_finalize();
1342 initialized = UIM_FALSE;
1343 }
1344