1
/*===========================================================================
2
* Filename : module-siod.c
3
* About : SIOD compatible procedures
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>
10
* All rights reserved.
12
* Redistribution and use in source and binary forms, with or without
13
* modification, are permitted provided that the following conditions
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.
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
===========================================================================*/
42
#include "sigscheme.h"
43
#include "sigschemeinternal.h"
44
#include "scmport-null.h"
46
/*=======================================
47
File Local Macro Definitions
48
=======================================*/
50
* SIOD's verbose-level compatible debug message printing control:
51
* Search 'siod_verbose_level' in slib.c to know further detail.
53
* Don't change the verbose level 2 for SCM_DBG_BACKTRACE. This is used to
54
* suppress backtrace when run by the testing framework of uim.
55
* -- YamaKen 2005-11-05
58
* v0: suppress all printing even if normal 'write' or 'display'
59
* v1: print each result of repl
60
* v2: print the "> " prompt
62
#define SCM_DBG_SIOD_V0 SCM_DBG_NONE
63
#define SCM_DBG_SIOD_V1 SCM_DBG_ERRMSG
64
#define SCM_DBG_SIOD_V2 (SCM_DBG_SIOD_V1 | SCM_DBG_BACKTRACE)
65
#define SCM_DBG_SIOD_V3 (SCM_DBG_SIOD_V2 | SCM_DBG_FILE)
66
#define SCM_DBG_SIOD_V4 (SCM_DBG_SIOD_V3 | SCM_DBG_GC)
67
#define SCM_DBG_SIOD_V5 (SCM_DBG_SIOD_V4 | SCM_DBG_READ)
69
/*=======================================
70
File Local Type Definitions
71
=======================================*/
73
/*=======================================
75
=======================================*/
76
#include "functable-siod.c"
78
static const int sscm_debug_mask_tbl[] = {
87
SCM_GLOBAL_VARS_BEGIN(static_siod);
89
static long l_sscm_verbose_level;
91
static ScmObj l_null_port;
92
static ScmObj l_saved_output_port;
93
static ScmObj l_saved_error_port;
95
SCM_GLOBAL_VARS_END(static_siod);
96
#define l_sscm_verbose_level SCM_GLOBAL_VAR(static_siod, l_sscm_verbose_level)
97
#define l_null_port SCM_GLOBAL_VAR(static_siod, l_null_port)
98
#define l_saved_output_port SCM_GLOBAL_VAR(static_siod, l_saved_output_port)
99
#define l_saved_error_port SCM_GLOBAL_VAR(static_siod, l_saved_error_port)
100
SCM_DEFINE_STATIC_VARS(static_siod);
102
/*=======================================
103
File Local Function Declarations
104
=======================================*/
106
/*=======================================
108
=======================================*/
110
scm_initialize_siod(void)
114
SCM_GLOBAL_VARS_INIT(static_siod);
116
scm_register_funcs(scm_functable_siod);
118
#if SCM_COMPAT_SIOD_BUGS
119
scm_define_alias("=", "%%siod=");
122
scm_require_module("sscm-ext");
123
scm_define_alias("the-environment", "%%current-environment");
125
scm_require_module("srfi-60");
126
scm_define_alias("bit-and", "logand");
127
scm_define_alias("bit-or", "logior");
128
scm_define_alias("bit-xor", "logxor");
129
scm_define_alias("bit-not", "lognot");
131
scm_gc_protect_with_init(&l_null_port, SCM_FALSE);
132
scm_gc_protect_with_init(&l_saved_output_port, SCM_FALSE);
133
scm_gc_protect_with_init(&l_saved_error_port, SCM_FALSE);
136
cport = scm_make_char_port(ScmNullPort_new());
137
l_null_port = MAKE_PORT(cport, SCM_PORTFLAG_INPUT | SCM_PORTFLAG_OUTPUT);
139
/* To allow re-initialization of the interpreter, this variables must be
140
* initialized by assignment. Initialized .data section does not work for
141
* such situation. -- YamaKen 2006-03-31 */
142
l_sscm_verbose_level = -1;
143
scm_set_verbose_level(2);
148
* - replace with a portable proc such as (eval 'sym (interaction-environment))
149
* - make the portable proc interface similar to a de facto standard of other
150
* Scheme implementations if existing
153
scm_p_symbol_value(ScmObj var)
155
DECLARE_FUNCTION("symbol-value", procedure_fixed_1);
159
return scm_symbol_value(var, SCM_INTERACTION_ENV);
164
* - replace with a portable proc such as (eval '(set! sym val)
165
* (interaction-environment))
166
* - make the portable proc interface similar to a de facto standard of other
167
* Scheme implementations if existing
170
scm_p_set_symbol_valuex(ScmObj var, ScmObj val)
172
DECLARE_FUNCTION("set-symbol-value!", procedure_fixed_2);
176
SCM_SYMBOL_SET_VCELL(var, val);
182
scm_p_siod_equal(ScmObj obj1, ScmObj obj2)
184
DECLARE_FUNCTION("%%siod=", procedure_fixed_2);
189
if (!INTP(obj1) || !INTP(obj2))
191
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
194
/* TODO: remove this once uim has been revised */
196
scm_p_closure_code(ScmObj closure)
199
DECLARE_FUNCTION("%%closure-code", procedure_fixed_1);
201
ENSURE_CLOSURE(closure);
203
exp = SCM_CLOSURE_EXP(closure);
204
/* make SIOD-compatible 'begin' -prefixed body */
205
body = CONS(scm_intern("begin"), CDR(exp));
207
return CONS(CAR(exp), body);
211
scm_p_verbose(ScmObj args)
214
DECLARE_FUNCTION("verbose", procedure_variadic_0);
218
ASSERT_NO_MORE_ARG(args);
221
scm_set_verbose_level(SCM_INT_VALUE(level));
224
return MAKE_INT(l_sscm_verbose_level);
230
DECLARE_FUNCTION("eof-val", procedure_fixed_0);
236
scm_s_undefine(ScmObj var, ScmObj env)
239
DECLARE_FUNCTION("undefine", syntax_fixed_1);
243
val = scm_lookup_environment(var, env);
244
if (val != SCM_INVALID_REF)
245
SET(val, SCM_UNBOUND);
247
SCM_SYMBOL_SET_VCELL(var, SCM_UNBOUND);
253
scm_get_verbose_level(void)
255
return l_sscm_verbose_level;
259
scm_set_verbose_level(long level)
261
DECLARE_INTERNAL_FUNCTION("scm_set_verbose_level");
264
ERR("non-negative value required but got: ~LD", level);
266
if (l_sscm_verbose_level == level)
269
l_sscm_verbose_level = level;
273
scm_set_debug_categories(sscm_debug_mask_tbl[level]);
276
scm_set_debug_categories(scm_debug_categories()
277
| scm_predefined_debug_categories());
280
if (!EQ(scm_err, l_null_port))
281
l_saved_error_port = scm_err;
282
if (!EQ(scm_out, l_null_port))
283
l_saved_output_port = scm_out;
285
scm_err = l_null_port;
286
scm_out = l_null_port;
288
if (EQ(scm_err, l_null_port))
289
scm_err = l_saved_error_port;
290
if (EQ(scm_out, l_null_port))
291
scm_out = l_saved_output_port;
added
removed
sigscheme/src/module-siod.c
