3
Copyright (c) 2003-2006 uim Project http://uim.freedesktop.org/
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
42
#include "uim-stdint.h"
44
#include "uim-compat-scm.h"
45
#include "uim-internal.h"
48
To avoid namespace pollution, all siod functions are defined as
49
static and wrapped into uim-scm.c by direct inclusion rather than
50
linked via public symbols. After elaboration of uim-scm API, the
51
Scheme interpreter implementation can be switched to another one
52
such as uim-scm-tinyscheme.c or uim-scm-gauche.c. But *.[hc] under
53
uim/ and *.scm are still depending on siod in several ways. At least
54
full test suite for *.scm files are required to migrate to another
55
Scheme implementation. -- YamaKen 2004-12-21, 2005-01-10
59
#include "uim-compat-scm.c"
62
static void siod_init_subr(const char *name, long type, SUBR_FUNC fcn);
64
#if UIM_SCM_GCC4_READY_GC
65
static int uim_scm_c_int_internal(uim_lisp integer);
66
static const char *uim_scm_refer_c_str_internal(uim_lisp str);
67
static uim_lisp uim_scm_eval_internal(uim_lisp obj);
68
static void siod_init_subr_internal(const char *name, long type, SUBR_FUNC fcn);
69
static uim_lisp uim_scm_eval_c_string_internal(const char *str);
72
static uim_lisp true_sym;
73
static uim_lisp false_sym;
74
static uim_lisp protected_arg0;
76
static int uim_siod_fatal;
77
static FILE *uim_output = NULL;
79
#if UIM_SCM_GCC4_READY_GC
80
/* See also the comment about these variables in uim-scm.h */
81
uim_lisp *(*volatile uim_scm_gc_current_stack_ptr)(void)
82
= &uim_scm_gc_current_stack_internal;
83
uim_lisp *(*volatile uim_scm_gc_protect_stack_ptr)(uim_lisp *)
84
= &uim_scm_gc_protect_stack_internal;
85
#endif /* UIM_SCM_GCC4_READY_GC */
89
uim_scm_get_output(void)
95
uim_scm_set_output(FILE *fp)
101
uim_scm_c_bool(uim_lisp val)
103
return UIM_SCM_NFALSEP(val);
107
uim_scm_make_bool(uim_bool val)
109
return (val) ? uim_scm_t() : uim_scm_f();
113
uim_scm_c_int(uim_lisp integer)
114
#if UIM_SCM_GCC4_READY_GC
118
UIM_SCM_GC_PROTECTED_CALL(ret, int, uim_scm_c_int_internal, (integer));
124
uim_scm_c_int_internal(uim_lisp integer)
128
#if !UIM_SCM_GCC4_READY_GC
129
uim_lisp stack_start;
131
/* stack protection is required for my_err() */
132
uim_scm_gc_protect_stack(&stack_start);
135
protected_arg0 = integer;
136
c_int = get_c_int((LISP)integer);
138
#if !UIM_SCM_GCC4_READY_GC
139
uim_scm_gc_unprotect_stack(&stack_start);
146
uim_scm_make_int(int integer)
148
return (uim_lisp)intcons(integer);
152
uim_scm_c_str(uim_lisp str)
156
c_str = uim_scm_refer_c_str(str);
158
return (c_str) ? strdup(c_str) : NULL;
162
uim_scm_refer_c_str(uim_lisp str)
163
#if UIM_SCM_GCC4_READY_GC
167
UIM_SCM_GC_PROTECTED_CALL(ret, const char *, uim_scm_refer_c_str_internal, (str));
173
uim_scm_refer_c_str_internal(uim_lisp str)
177
#if !UIM_SCM_GCC4_READY_GC
178
uim_lisp stack_start;
180
/* stack protection is required for my_err() */
181
uim_scm_gc_protect_stack(&stack_start);
184
protected_arg0 = str;
185
c_str = get_c_string((LISP)str);
187
#if !UIM_SCM_GCC4_READY_GC
188
uim_scm_gc_unprotect_stack(&stack_start);
195
uim_scm_make_str(const char *str)
197
int unknown_strlen = -1;
198
return (uim_lisp)strcons(unknown_strlen, str);
202
uim_scm_c_symbol(uim_lisp symbol)
205
return uim_scm_c_str(symbol);
209
uim_scm_make_symbol(const char *str)
211
return (uim_lisp)rintern(str);
215
uim_scm_c_ptr(uim_lisp ptr)
217
return get_c_pointer((LISP)ptr);
221
uim_scm_make_ptr(void *ptr)
223
return (uim_lisp)ptrcons(ptr);
227
uim_scm_c_func_ptr(uim_lisp func_ptr)
229
return get_c_func_pointer((LISP)func_ptr);
233
uim_scm_make_func_ptr(uim_func_ptr func_ptr)
235
return (uim_lisp)funcptrcons(func_ptr);
239
uim_scm_gc_protect(uim_lisp *location)
241
siod_gc_protect((LISP *)location);
245
uim_scm_gc_unprotect_stack(uim_lisp *stack_start)
247
siod_gc_unprotect_stack((LISP *)stack_start);
250
#if UIM_SCM_GCC4_READY_GC
251
/* uim_scm_gc_current_stack_internal() is separated from
252
* uim_scm_gc_protect_stack_internal() to avoid returning inaccurate
253
* stack-start address. Don't add any code fragments such as
254
* assertions or printfs to this function. It may alter the stack address.
255
* -- YamaKen 2006-06-04 */
257
uim_scm_gc_current_stack_internal(void)
260
* &stack_start will be relocated to start of the frame of subsequent
265
/* intentionally returns invalidated local address with a warning
266
* suppression workaround */
267
return (void *)(((uintptr_t)&stack_start | 1) ^ 1);
271
uim_scm_gc_protect_stack_internal(uim_lisp *stack_start)
273
siod_gc_protect_stack((LISP *)stack_start);
275
return (uim_lisp *)stack_start_ptr;
277
#else /* UIM_SCM_GCC4_READY_GC */
279
uim_scm_gc_protect_stack(uim_lisp *stack_start)
281
siod_gc_protect_stack((LISP *)stack_start);
283
#endif /* UIM_SCM_GCC4_READY_GC */
286
uim_scm_is_alive(void)
288
return (!uim_siod_fatal);
292
uim_scm_get_verbose_level(void)
294
return siod_verbose_level;
298
uim_scm_set_verbose_level(long new_value)
300
siod_verbose_level = new_value;
304
uim_scm_set_lib_path(const char *path)
306
siod_set_lib_path(path);
310
uim_scm_load_file(const char *fn)
317
UIM_EVAL_FSTRING1(NULL, "(*catch 'errobj (load \"%s\" #f #f))", fn);
318
succeeded = UIM_SCM_FALSEP(uim_scm_return_value()); /* has not been caught */
326
return (uim_lisp)true_sym;
332
return (uim_lisp)false_sym;
336
uim_scm_null_list(void)
338
return (uim_lisp)NIL;
342
uim_scm_nullp(uim_lisp obj)
344
return NULLP((LISP)obj);
348
uim_scm_consp(uim_lisp obj)
350
return CONSP((LISP)obj);
354
uim_scm_integerp(uim_lisp obj)
356
return INTNUMP((LISP)obj);
360
uim_scm_stringp(uim_lisp obj)
362
return STRINGP((LISP)obj);
366
uim_scm_eq(uim_lisp a, uim_lisp b)
372
uim_scm_string_equal(uim_lisp a, uim_lisp b)
374
return UIM_SCM_NFALSEP((uim_lisp)string_equal((LISP)a, (LISP)b));
378
uim_scm_eval(uim_lisp obj)
379
#if UIM_SCM_GCC4_READY_GC
383
UIM_SCM_GC_PROTECTED_CALL(ret, uim_lisp, uim_scm_eval_internal, (obj));
389
uim_scm_eval_internal(uim_lisp obj)
392
uim_lisp ret; /* intentionally outside of next stack_start */
393
#if !UIM_SCM_GCC4_READY_GC
394
uim_lisp stack_start;
396
uim_scm_gc_protect_stack(&stack_start);
399
ret = (uim_lisp)leval((LISP)obj, NIL);
401
#if !UIM_SCM_GCC4_READY_GC
402
uim_scm_gc_unprotect_stack(&stack_start);
409
uim_scm_eval_c_string(const char *str)
410
#if UIM_SCM_GCC4_READY_GC
414
UIM_SCM_GC_PROTECTED_CALL(ret, uim_lisp, uim_scm_eval_c_string_internal, (str));
420
uim_scm_eval_c_string_internal(const char *str)
423
repl_c_string((char *)str, 0, 0);
424
return uim_scm_return_value();
428
uim_scm_return_value(void)
430
return (uim_lisp)siod_return_value();
434
uim_scm_car(uim_lisp cell)
436
return (uim_lisp)car((LISP)cell);
440
uim_scm_cdr(uim_lisp cell)
442
return (uim_lisp)cdr((LISP)cell);
446
uim_scm_cadr(uim_lisp cell)
448
return (uim_lisp)cadr((LISP)cell);
452
uim_scm_caar(uim_lisp cell)
454
return (uim_lisp)caar((LISP)cell);
458
uim_scm_cdar(uim_lisp cell)
460
return (uim_lisp)cdar((LISP)cell);
464
uim_scm_cddr(uim_lisp cell)
466
return (uim_lisp)cddr((LISP)cell);
470
uim_scm_cons(uim_lisp car, uim_lisp cdr)
472
return (uim_lisp)cons((LISP)car, (LISP)cdr);
476
uim_scm_length(uim_lisp list)
479
although nlength() of siod returns length of anything, this
480
function should be called only for list
482
return (uim_lisp)uim_scm_make_int(nlength((LISP)list));
486
uim_scm_reverse(uim_lisp cell)
488
return (uim_lisp)reverse((LISP)cell);
492
uim_scm_require_file(const char *fn)
499
UIM_EVAL_FSTRING2(NULL, "(eq? '*%s-loaded* (*catch 'errobj (require \"%s\")))", fn, fn);
500
succeeded = uim_scm_c_bool(uim_scm_return_value());
506
siod_init_subr(const char *name, long type, SUBR_FUNC fcn)
507
#if UIM_SCM_GCC4_READY_GC
509
UIM_SCM_GC_PROTECTED_CALL_VOID(siod_init_subr_internal, (name, type, fcn));
513
siod_init_subr_internal(const char *name, long type, SUBR_FUNC fcn)
515
init_subr(name, type, fcn);
519
uim_lisp stack_start;
521
uim_scm_gc_protect_stack(&stack_start);
522
init_subr(name, type, fcn);
523
uim_scm_gc_unprotect_stack(&stack_start);
528
uim_scm_init_subr_0(const char *name, uim_lisp (*fcn)(void))
530
siod_init_subr(name, tc_subr_0, (SUBR_FUNC)fcn);
534
uim_scm_init_subr_1(const char *name, uim_lisp (*fcn)(uim_lisp))
536
siod_init_subr(name, tc_subr_1, (SUBR_FUNC)fcn);
540
uim_scm_init_subr_2(const char *name, uim_lisp (*fcn)(uim_lisp, uim_lisp))
542
siod_init_subr(name, tc_subr_2, (SUBR_FUNC)fcn);
546
uim_scm_init_subr_3(const char *name, uim_lisp (*fcn)(uim_lisp, uim_lisp, uim_lisp))
548
siod_init_subr(name, tc_subr_3, (SUBR_FUNC)fcn);
552
uim_scm_init_subr_4(const char *name, uim_lisp (*fcn)(uim_lisp, uim_lisp, uim_lisp,
555
siod_init_subr(name, tc_subr_4, (SUBR_FUNC)fcn);
559
uim_scm_init_subr_5(const char *name, uim_lisp (*fcn)(uim_lisp, uim_lisp, uim_lisp,
562
siod_init_subr(name, tc_subr_5, (SUBR_FUNC)fcn);
572
uim_scm_init(const char *verbose_level)
577
"-v2", /* siod_verbose_level */
578
"-h16384:64", /* heap_size(unit: lisp objects):nheaps */
579
"-t16384", /* heap_alloc_threshold (unit: lisp objects) */
580
"-o1024", /* obarray_dim (hash size of symbol table) */
581
"-s262144", /* stack_size (unit: bytes) */
582
"-n128" /* inums_dim (preallocated fixnum objects) */
584
char verbose_argv[] = "-v2";
585
int siod_argc, warnflag = 1;
592
if (isdigit((int)verbose_level[0])) {
593
if (isdigit((int)verbose_level[1]))
594
verbose_argv[2] = '9'; /* SIOD's max verbose level is 5 */
596
verbose_argv[2] = verbose_level[0];
598
siod_argv[1] = verbose_argv;
601
siod_argc = sizeof(siod_argv) / sizeof(char *);
602
siod_init(siod_argc, siod_argv, warnflag, uim_output);
603
set_fatal_exit_hook(exit_hook);
605
true_sym = (uim_lisp)siod_true_value();
607
false_sym = (uim_lisp)siod_false_value();
609
/* false_sym has to be NIL until bug #617 and #642 are fixed
612
false_sym = (uim_lisp)NIL;
614
uim_scm_gc_protect(&true_sym);
615
uim_scm_gc_protect(&false_sym);
617
protected_arg0 = uim_scm_f();
618
uim_scm_gc_protect(&protected_arg0);
added
removed
uim/uim-scm.c
