3
Copyright (c) 2003-2008 uim Project http://code.google.com/p/uim/
7
Redistribution and use in source and binary forms, with or without
8
modification, are permitted provided that the following conditions
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.
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
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
40
/* This file must be included before uim's config.h */
41
#include "sigscheme-combined.c"
42
#if !SSCM_VERSION_REQUIRE(0, 7, 5)
43
#error "SigScheme version 0.7.5 or later is required"
53
#include "uim-stdint.h"
55
#include "uim-compat-scm.h"
56
#include "uim-internal.h"
60
#include "uim-compat-scm.c"
63
/* FIXME: illegal internal access */
64
#define scm_out SCM_GLOBAL_VAR(port, scm_out)
65
#define scm_err SCM_GLOBAL_VAR(port, scm_err)
67
static void uim_scm_error(const char *msg, uim_lisp errobj);
69
#if UIM_SCM_GCC4_READY_GC
70
struct uim_scm_error_args {
74
static void *uim_scm_error_internal(struct uim_scm_error_args *args);
76
static void *uim_scm_c_int_internal(void *uim_lisp_integer);
77
static const char *uim_scm_refer_c_str_internal(void *uim_lisp_str);
78
static void *uim_scm_eval_internal(void *uim_lisp_obj);
81
uim_lisp uim_scm_last_val;
82
static uim_bool sscm_is_exit_with_fatal_error;
83
static FILE *uim_output = NULL;
86
uim_scm_error(const char *msg, uim_lisp errobj)
87
#if UIM_SCM_GCC4_READY_GC
89
struct uim_scm_error_args args;
93
uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_error_internal, &args);
97
uim_scm_error_internal(struct uim_scm_error_args *args)
99
/* FIXME: don't terminate the process */
100
scm_error_obj(NULL, args->msg, (ScmObj)args->errobj);
103
#else /* UIM_SCM_GCC4_READY_GC */
105
uim_scm_error_internal(const char *msg, uim_lisp errobj)
107
uim_lisp stack_start;
109
uim_scm_gc_protect_stack(&stack_start);
111
/* FIXME: don't terminate the process */
112
scm_error_obj(NULL, msg, (ScmObj)errobj);
114
uim_scm_gc_unprotect_stack(&stack_start);
116
#endif /* UIM_SCM_GCC4_READY_GC */
119
uim_scm_get_output(void)
125
uim_scm_set_output(FILE *fp)
131
uim_scm_c_bool(uim_lisp val)
133
return UIM_SCM_NFALSEP(val);
137
uim_scm_make_bool(uim_bool val)
139
return (val) ? uim_scm_t() : uim_scm_f();
143
uim_scm_c_int(uim_lisp integer)
144
#if UIM_SCM_GCC4_READY_GC
146
return (int)(intptr_t)uim_scm_call_with_gc_ready_stack(uim_scm_c_int_internal, (void *)integer);
150
uim_scm_c_int_internal(void *uim_lisp_integer)
154
#if UIM_SCM_GCC4_READY_GC
157
uim_lisp stack_start;
160
#if UIM_SCM_GCC4_READY_GC
161
integer = (uim_lisp)uim_lisp_integer;
163
/* stack protection is required for my_err() */
164
uim_scm_gc_protect_stack(&stack_start);
167
if (SCM_INTP((ScmObj)integer)) {
168
c_int = SCM_INT_VALUE((ScmObj)integer);
170
uim_scm_error("uim_scm_c_int: number required but got ",
175
#if UIM_SCM_GCC4_READY_GC
176
return (void *)(intptr_t)c_int;
178
uim_scm_gc_unprotect_stack(&stack_start);
185
uim_scm_make_int(int integer)
187
return (uim_lisp)SCM_MAKE_INT(integer);
191
uim_scm_c_str(uim_lisp str)
195
c_str = uim_scm_refer_c_str(str);
197
return (c_str) ? strdup(c_str) : NULL;
201
uim_scm_refer_c_str(uim_lisp str)
202
#if UIM_SCM_GCC4_READY_GC
204
return uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)uim_scm_refer_c_str_internal, (void *)str);
208
uim_scm_refer_c_str_internal(void *uim_lisp_str)
212
#if UIM_SCM_GCC4_READY_GC
215
uim_lisp stack_start;
218
#if UIM_SCM_GCC4_READY_GC
219
str = (uim_lisp)uim_lisp_str;
221
/* stack protection is required for my_err() */
222
uim_scm_gc_protect_stack(&stack_start);
225
if (SCM_STRINGP((ScmObj)str)) {
226
c_str = SCM_STRING_STR((ScmObj)str);
227
} else if (SCM_SYMBOLP((ScmObj)str)) {
228
c_str = SCM_SYMBOL_NAME((ScmObj)str);
230
uim_scm_error("uim_scm_refer_c_str: string or symbol required but got ",
235
#if !UIM_SCM_GCC4_READY_GC
236
uim_scm_gc_unprotect_stack(&stack_start);
243
uim_scm_make_str(const char *str)
245
return (uim_lisp)SCM_MAKE_STRING_COPYING(str, SCM_STRLEN_UNKNOWN);
249
uim_scm_c_symbol(uim_lisp symbol)
251
return strdup((char *)SCM_SYMBOL_NAME((ScmObj)symbol));
255
uim_scm_make_symbol(const char *name)
257
return (uim_lisp)scm_intern(name);
261
uim_scm_c_ptr(uim_lisp ptr)
263
if (SCM_C_POINTERP((ScmObj)ptr)) {
264
return SCM_C_POINTER_VALUE((ScmObj)ptr);
266
uim_scm_error("uim_scm_c_ptr: C pointer required but got ", (uim_lisp)ptr);
272
uim_scm_make_ptr(void *ptr)
274
return (uim_lisp)SCM_MAKE_C_POINTER(ptr);
278
uim_scm_c_func_ptr(uim_lisp func_ptr)
280
if (SCM_C_FUNCPOINTERP((ScmObj)func_ptr)) {
281
return SCM_C_FUNCPOINTER_VALUE((ScmObj)func_ptr);
283
uim_scm_error("uim_scm_c_func_ptr: C function pointer required but got ",
290
uim_scm_make_func_ptr(uim_func_ptr func_ptr)
292
return (uim_lisp)SCM_MAKE_C_FUNCPOINTER((ScmCFunc)func_ptr);
296
uim_scm_gc_protect(uim_lisp *location)
298
scm_gc_protect((ScmObj *)location);
301
#if UIM_SCM_GCC4_READY_GC
303
uim_scm_gc_unprotect(uim_lisp *location)
305
scm_gc_unprotect((ScmObj *)location);
309
uim_scm_call_with_gc_ready_stack(uim_gc_gate_func_ptr func, void *arg)
311
return scm_call_with_gc_ready_stack(func, arg);
315
uim_scm_gc_unprotect_stack(uim_lisp *stack_start)
317
scm_gc_unprotect_stack((ScmObj*)stack_start);
321
uim_scm_gc_protect_stack(uim_lisp *stack_start)
323
scm_gc_protect_stack((ScmObj*)stack_start);
325
#endif /* UIM_SCM_GCC4_READY_GC */
328
uim_scm_is_alive(void)
330
return (!sscm_is_exit_with_fatal_error);
334
uim_scm_get_verbose_level(void)
336
return (long)scm_get_verbose_level();
340
uim_scm_set_verbose_level(long new_value)
342
scm_set_verbose_level(new_value);
346
uim_scm_set_lib_path(const char *path)
348
scm_set_lib_path(path);
352
uim_scm_load_file(const char *fn)
359
UIM_EVAL_FSTRING1(NULL, "(guard (err (else #f)) (load \"%s\"))", fn);
360
succeeded = uim_scm_c_bool(uim_scm_return_value());
368
return (uim_lisp)SCM_TRUE;
374
return (uim_lisp)SCM_FALSE;
378
uim_scm_null_list(void)
380
return (uim_lisp)SCM_NULL;
384
uim_scm_nullp(uim_lisp obj)
386
return (SCM_NULLP((ScmObj)obj));
390
uim_scm_consp(uim_lisp obj)
392
return (SCM_CONSP((ScmObj)obj));
396
uim_scm_integerp(uim_lisp obj)
398
return (SCM_INTP((ScmObj)obj));
402
uim_scm_stringp(uim_lisp obj)
404
return (SCM_STRINGP((ScmObj)obj));
408
uim_scm_eq(uim_lisp a, uim_lisp b)
410
return (SCM_EQ((ScmObj)a, (ScmObj)b));
414
uim_scm_string_equal(uim_lisp a, uim_lisp b)
416
return (SCM_TRUEP(scm_p_stringequalp((ScmObj)a, (ScmObj)b)));
420
uim_scm_eval(uim_lisp obj)
421
#if UIM_SCM_GCC4_READY_GC
423
return (uim_lisp)uim_scm_call_with_gc_ready_stack(uim_scm_eval_internal,
428
uim_scm_eval_internal(void *uim_lisp_obj)
431
uim_lisp ret; /* intentionally outside of next stack_start */
432
#if UIM_SCM_GCC4_READY_GC
435
uim_lisp stack_start;
438
#if UIM_SCM_GCC4_READY_GC
439
obj = (uim_lisp)uim_lisp_obj;
441
uim_scm_gc_protect_stack(&stack_start);
444
uim_scm_last_val = ret = (uim_lisp)scm_p_eval((ScmObj)obj, SCM_NULL);
446
#if UIM_SCM_GCC4_READY_GC
449
uim_scm_gc_unprotect_stack(&stack_start);
456
uim_scm_eval_c_string(const char *str)
458
uim_scm_last_val = (uim_lisp)scm_eval_c_string(str);
460
return uim_scm_last_val;
464
uim_scm_return_value(void)
466
/* FIXME: This function should be removed. */
467
return uim_scm_last_val;
471
uim_scm_car(uim_lisp pair)
473
return (uim_lisp)scm_p_car((ScmObj)pair);
477
uim_scm_cdr(uim_lisp pair)
479
return (uim_lisp)scm_p_cdr((ScmObj)pair);
483
uim_scm_cadr(uim_lisp lst)
485
return (uim_lisp)scm_p_cadr((ScmObj)lst);
489
uim_scm_caar(uim_lisp lst)
491
return (uim_lisp)scm_p_caar((ScmObj)lst);
495
uim_scm_cdar(uim_lisp lst)
497
return (uim_lisp)scm_p_cdar((ScmObj)lst);
501
uim_scm_cddr(uim_lisp lst)
503
return (uim_lisp)scm_p_cddr((ScmObj)lst);
507
uim_scm_cons(uim_lisp car, uim_lisp cdr)
509
return (uim_lisp)SCM_CONS((ScmObj)car, (ScmObj)cdr);
513
uim_scm_length(uim_lisp lst)
516
although nlength() of siod returns length of anything, this
517
function should be called only for list
519
return (uim_lisp)scm_p_length((ScmObj)lst);
523
uim_scm_reverse(uim_lisp lst)
525
return (uim_lisp)scm_p_reverse((ScmObj)lst);
529
uim_scm_require_file(const char *fn)
536
UIM_EVAL_FSTRING1(NULL, "(guard (err (else #f)) (require \"%s\"))", fn);
537
succeeded = uim_scm_c_bool(uim_scm_return_value());
543
uim_scm_init_subr_0(const char *name, uim_lisp (*func)(void))
545
scm_register_func(name, (scm_procedure_fixed_0)func, SCM_PROCEDURE_FIXED_0);
549
uim_scm_init_subr_1(const char *name, uim_lisp (*func)(uim_lisp))
551
scm_register_func(name, (scm_procedure_fixed_1)func, SCM_PROCEDURE_FIXED_1);
555
uim_scm_init_subr_2(const char *name, uim_lisp (*func)(uim_lisp, uim_lisp))
557
scm_register_func(name, (scm_procedure_fixed_2)func, SCM_PROCEDURE_FIXED_2);
561
uim_scm_init_subr_3(const char *name, uim_lisp (*func)(uim_lisp, uim_lisp, uim_lisp))
563
scm_register_func(name, (scm_procedure_fixed_3)func, SCM_PROCEDURE_FIXED_3);
567
uim_scm_init_subr_4(const char *name, uim_lisp (*func)(uim_lisp, uim_lisp, uim_lisp,
570
scm_register_func(name, (scm_procedure_fixed_4)func, SCM_PROCEDURE_FIXED_4);
574
uim_scm_init_subr_5(const char *name, uim_lisp (*func)(uim_lisp, uim_lisp, uim_lisp,
577
scm_register_func(name, (scm_procedure_fixed_5)func, SCM_PROCEDURE_FIXED_5);
583
sscm_is_exit_with_fatal_error = UIM_TRUE;
584
/* FIXME: Add longjmp() to outermost uim API call, and make all API
585
* calls uim_scm_is_alive()-sensitive. It should be fixed on uim
586
* 1.5. -- YamaKen 2006-06-06, 2006-12-27 */
590
uim_scm_init(const char *verbose_level)
592
ScmStorageConf storage_conf;
599
if (verbose_level && isdigit((unsigned char)verbose_level[0])) {
600
vlevel = atoi(verbose_level) % 10;
603
#if SCM_USE_MULTIBYTE_CHAR
604
/* *GC safe operation*
606
* Set the raw unibyte codec which accepts all (multi)byte sequence
607
* although it slashes a multibyte character on Scheme-level
608
* character processing. Since current uim implementation treats a
609
* multibyte character as string, it is not a problem. The name
610
* "ISO-8859-1" is a dummy name for the codec.
612
scm_current_char_codec = scm_mb_find_codec("ISO-8859-1");
615
/* 128KB/heap, max 0.99GB on 32-bit systems. Since maximum length of list can
616
* be represented by a Scheme integer, SCM_INT_MAX limits the number of cons
618
storage_conf.heap_size = 16384;
619
storage_conf.heap_alloc_threshold = 16384;
620
storage_conf.n_heaps_max = SCM_INT_MAX / storage_conf.heap_size;
621
storage_conf.n_heaps_init = 1;
622
storage_conf.symbol_hash_size = 1024;
623
scm_initialize(&storage_conf);
624
scm_set_fatal_error_callback(exit_hook);
627
output_port = scm_make_shared_file_port(uim_output, "uim", SCM_PORTFLAG_OUTPUT);
628
scm_out = scm_err = output_port;
631
/* required by test-im.scm */
632
uim_scm_provide("debug");
639
uim_scm_gc_protect(&uim_scm_last_val);
640
uim_scm_set_verbose_level(vlevel);
647
sscm_is_exit_with_fatal_error = UIM_FALSE;
added
removed
uim/uim-scm.c
