1 /*===========================================================================
2 * Filename : eval.c
3 * About : Evaluation and function calling
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 "sigscheme.h"
41 #include "sigschemeinternal.h"
42
43 /*=======================================
44 File Local Macro Definitions
45 =======================================*/
46 #define SCM_ERRMSG_NON_R5RS_ENV "the environment is not conformed to R5RS"
47
48 /*=======================================
49 File Local Type Definitions
50 =======================================*/
51
52 /*=======================================
53 Variable Definitions
54 =======================================*/
55
56 /*=======================================
57 File Local Function Declarations
58 =======================================*/
59 static ScmObj reduce(ScmObj (*func)(), ScmObj args, ScmObj env,
60 enum ScmValueType need_eval);
61 #if SCM_USE_CONTINUATION
62 static void call_continuation(ScmObj cont, ScmObj args,
63 ScmEvalState *eval_state,
64 enum ScmValueType need_eval) SCM_NORETURN;
65 #endif
66 static ScmObj call_closure(ScmObj proc, ScmObj args, ScmEvalState *eval_state,
67 enum ScmValueType need_eval);
68 static ScmObj call(ScmObj proc, ScmObj args, ScmEvalState *eval_state,
69 enum ScmValueType need_eval);
70 static ScmObj map_eval(ScmObj args, scm_int_t *args_len, ScmObj env);
71
72 /*=======================================
73 Function Definitions
74 =======================================*/
75 /* Wrapper for call(). Just like scm_p_apply(), except ARGS is used
76 * as given---nothing special is done about the last item in the
77 * list. */
78 SCM_EXPORT ScmObj
scm_call(ScmObj proc,ScmObj args)79 scm_call(ScmObj proc, ScmObj args)
80 {
81 ScmEvalState state;
82 ScmObj ret;
83
84 SCM_ASSERT(PROPER_LISTP(args));
85
86 /* We don't need a nonempty environemnt, because this function
87 * will never be called directly from Scheme code. If PROC is a
88 * closure, it'll have its own environment, if it's a syntax, it's
89 * an error, and if it's a C procedure, it doesn't have any free
90 * variables at the Scheme level. */
91 SCM_EVAL_STATE_INIT2(state, SCM_INTERACTION_ENV, SCM_VALTYPE_AS_IS);
92
93 ret = call(proc, args, &state, SCM_VALTYPE_AS_IS);
94 return SCM_FINISH_TAILREC_CALL(ret, &state);
95 }
96
97 /* ARGS should NOT have been evaluated yet. */
98 static ScmObj
reduce(ScmObj (* func)(),ScmObj args,ScmObj env,enum ScmValueType need_eval)99 reduce(ScmObj (*func)(), ScmObj args, ScmObj env, enum ScmValueType need_eval)
100 {
101 ScmObj left, right;
102 enum ScmReductionState state;
103 DECLARE_INTERNAL_FUNCTION("(reduction)");
104
105 if (NO_MORE_ARG(args)) {
106 state = SCM_REDUCE_0;
107 return (*func)(SCM_INVALID, SCM_INVALID, &state);
108 }
109
110 left = POP(args);
111 if (need_eval)
112 left = EVAL(left, env);
113
114 if (NO_MORE_ARG(args)) {
115 state = SCM_REDUCE_1;
116 return (*func)(left, left, &state);
117 }
118
119 /* Reduce upto the penult. */
120 state = SCM_REDUCE_PARTWAY;
121 FOR_EACH_BUTLAST (right, args) {
122 if (need_eval)
123 right = EVAL(right, env);
124 left = (*func)(left, right, &state);
125 if (state == SCM_REDUCE_STOP)
126 return left;
127 }
128 ASSERT_NO_MORE_ARG(args);
129
130 /* Make the last call. */
131 state = SCM_REDUCE_LAST;
132 if (need_eval)
133 right = EVAL(right, env);
134 return (*func)(left, right, &state);
135 }
136
137 #if SCM_USE_CONTINUATION
138 static void
call_continuation(ScmObj cont,ScmObj args,ScmEvalState * eval_state,enum ScmValueType need_eval)139 call_continuation(ScmObj cont, ScmObj args, ScmEvalState *eval_state,
140 enum ScmValueType need_eval)
141 {
142 ScmObj ret;
143 scm_int_t args_len;
144 DECLARE_INTERNAL_FUNCTION("call_continuation");
145
146 /* (receive (x y) (call/cc (lambda (k) (k 0 1)))) */
147 if (LIST_1_P(args)) {
148 ret = CAR(args);
149 if (need_eval)
150 ret = EVAL(ret, eval_state->env);
151 } else {
152 ret = (need_eval) ? map_eval(args, &args_len, eval_state->env) : args;
153 ret = SCM_MAKE_VALUEPACKET(ret);
154 }
155 scm_call_continuation(cont, ret);
156 /* NOTREACHED */
157 }
158 #endif /* SCM_USE_CONTINUATION */
159
160 static ScmObj
call_closure(ScmObj proc,ScmObj args,ScmEvalState * eval_state,enum ScmValueType need_eval)161 call_closure(ScmObj proc, ScmObj args, ScmEvalState *eval_state,
162 enum ScmValueType need_eval)
163 {
164 ScmObj exp, formals, body, proc_env;
165 scm_int_t formals_len, args_len;
166 DECLARE_INTERNAL_FUNCTION("call_closure");
167
168 /*
169 * Description of the ScmClosure handling
170 *
171 * (lambda <formals> <body>)
172 *
173 * <formals> may have 3 forms.
174 *
175 * (1) <variable>
176 * (2) (<variable1> <variable2> ...)
177 * (3) (<variable1> <variable2> ... <variable n-1> . <variable n>)
178 */
179 exp = SCM_CLOSURE_EXP(proc);
180 formals = CAR(exp);
181 body = CDR(exp);
182 proc_env = SCM_CLOSURE_ENV(proc);
183 if (need_eval) {
184 args = map_eval(args, &args_len, eval_state->env);
185 } else {
186 args_len = scm_validate_actuals(args);
187 if (SCM_LISTLEN_ERRORP(args_len))
188 goto err_improper;
189 }
190
191 if (IDENTIFIERP(formals)) {
192 /* (1) <variable> */
193 formals = LIST_1(formals);
194 args = LIST_1(args);
195 } else if (CONSP(formals)) {
196 /*
197 * (2) (<variable1> <variable2> ...)
198 * (3) (<variable1> <variable2> ... <variable n-1> . <variable n>)
199 *
200 * - dotted list is handled in env.c
201 */
202 /* scm_finite_length() is enough since formals is fully validated
203 * previously */
204 formals_len = scm_finite_length(formals);
205 if (!scm_valid_environment_extension_lengthp(formals_len, args_len))
206 goto err_improper;
207 } else if (NULLP(formals)) {
208 /*
209 * (2') <variable> is '()
210 */
211 if (args_len)
212 goto err_improper;
213
214 formals = args = SCM_NULL;
215 } else {
216 SCM_NOTREACHED;
217 }
218
219 eval_state->env = scm_extend_environment(formals, args, proc_env);
220 eval_state->ret_type = SCM_VALTYPE_NEED_EVAL;
221 return scm_s_body(body, eval_state);
222
223 err_improper:
224 ERR_OBJ("unmatched number or improper args", args);
225 }
226
227 /**
228 * @param proc The procedure or syntax to call.
229 * @param args The argument list.
230 * @param eval_state The calling evaluator's state.
231 * @param need_eval Indicates that @a args need be evaluated.
232 */
233 static ScmObj
call(ScmObj proc,ScmObj args,ScmEvalState * eval_state,enum ScmValueType need_eval)234 call(ScmObj proc, ScmObj args, ScmEvalState *eval_state,
235 enum ScmValueType need_eval)
236 {
237 ScmObj env, vals;
238 ScmObj (*func)();
239 enum ScmFuncTypeCode type;
240 scm_bool syntaxp;
241 int mand_count, i;
242 scm_int_t variadic_len;
243 /* The +2 is for rest and env. */
244 ScmObj argbuf[SCM_FUNCTYPE_MAND_MAX + 2];
245 DECLARE_INTERNAL_FUNCTION("(function call)");
246
247 env = eval_state->env;
248
249 if (need_eval)
250 proc = EVAL(proc, env);
251
252 while (!FUNCP(proc)) {
253 if (CLOSUREP(proc)) {
254 #if SCM_USE_LEGACY_MACRO
255 if (SYNTACTIC_CLOSUREP(proc)) {
256 ScmObj ret;
257 scm_bool toplevelp;
258
259 if (!need_eval)
260 ERR_OBJ("can't apply/map a macro", proc);
261
262 toplevelp = SCM_DEFINABLE_TOPLEVELP(eval_state);
263
264 ret = call_closure(proc, args, eval_state, SCM_VALTYPE_AS_IS);
265 /* eval the result into an as-is object */
266 ret = SCM_FINISH_TAILREC_CALL(ret, eval_state);
267 /* restore previous env */
268 eval_state->env = env;
269 /* Instruct evaluating returned object again as a syntactic
270 * form. */
271 eval_state->ret_type = SCM_VALTYPE_NEED_EVAL;
272 #if SCM_STRICT_TOPLEVEL_DEFINITIONS
273 /* Workaround to allow toplevel definitions by the returned
274 * form. See scm_eval(). */
275 if (toplevelp)
276 eval_state->nest = SCM_NEST_RETTYPE_BEGIN;
277 #endif
278
279 return ret;
280 } else
281 #endif /* SCM_USE_LEGACY_MACRO */
282 {
283 return call_closure(proc, args, eval_state, need_eval);
284 }
285 }
286 #if SCM_USE_HYGIENIC_MACRO
287 if (HMACROP(proc)) {
288 if (!need_eval)
289 ERR_OBJ("can't apply/map a macro", proc);
290 return scm_expand_macro(proc, args, eval_state);
291 }
292 #endif
293 /* Since scm_values_applier is a continuation, this block must precedes
294 * CONTINUATIONP(). */
295 if (EQ(proc, scm_values_applier)) {
296 if (!need_eval)
297 ERR("invalid multiple values application");
298 proc = MUST_POP_ARG(args);
299 vals = MUST_POP_ARG(args);
300 NO_MORE_ARG(args);
301
302 if (!VALUEPACKETP(vals)) {
303 /* got back a single value */
304 args = LIST_1(vals);
305 } else {
306 /* extract */
307 args = SCM_VALUEPACKET_VALUES(vals);
308 }
309 /* the values and the consumer must be both already evaluated
310 * though need_eval == scm_true */
311 need_eval = scm_false;
312 continue;
313 }
314 #if SCM_USE_CONTINUATION
315 if (CONTINUATIONP(proc)) {
316 call_continuation(proc, args, eval_state, need_eval);
317 /* NOTREACHED */
318 }
319 #endif
320 ERR_OBJ("procedure or syntax required but got", proc);
321 /* NOTREACHED */
322 }
323
324 /* We have a C function. */
325
326 type = SCM_FUNC_TYPECODE(proc);
327 func = SCM_FUNC_CFUNC(proc);
328
329 if (type == SCM_REDUCTION_OPERATOR)
330 return reduce(func, args, env, need_eval);
331
332 syntaxp = type & SCM_FUNCTYPE_SYNTAX;
333 if (syntaxp) {
334 if (need_eval)
335 need_eval = scm_false;
336 else
337 ERR_OBJ("can't apply/map a syntax", proc);
338 }
339
340 /* Collect mandatory arguments. */
341 mand_count = type & SCM_FUNCTYPE_MAND_MASK;
342 SCM_ASSERT(mand_count <= SCM_FUNCTYPE_MAND_MAX);
343 for (i = 0; i < mand_count; i++) {
344 argbuf[i] = MUST_POP_ARG(args);
345 if (need_eval)
346 argbuf[i] = EVAL(argbuf[i], env);
347 CHECK_VALID_EVALED_VALUE((ScmObj)argbuf[i]);
348 }
349
350 if (type & SCM_FUNCTYPE_VARIADIC) {
351 if (need_eval)
352 args = map_eval(args, &variadic_len, env);
353 #if 0
354 /* Since this check is expensive, each syntax should do. Other
355 * procedures are already ensured that having proper args here. */
356 else if (syntaxp && !PROPER_LISTP(args))
357 ERR_OBJ(SCM_ERRMSG_IMPROPER_ARGS, args);
358 #endif
359 argbuf[i++] = args;
360 } else {
361 ASSERT_NO_MORE_ARG(args);
362 }
363
364 if (type & SCM_FUNCTYPE_TAILREC) {
365 eval_state->ret_type = SCM_VALTYPE_NEED_EVAL;
366 #if (SIZEOF_VOID_P != SIZEOF_SCMOBJ)
367 /* eval_state cannot be stored into argbuf safely. */
368 argbuf[i++] = SCM_INVALID; /* dummy */
369 #else
370 argbuf[i++] = (ScmObj)eval_state;
371 #endif
372 } else {
373 eval_state->ret_type = SCM_VALTYPE_AS_IS;
374 if (type & SCM_FUNCTYPE_SYNTAX)
375 argbuf[i++] = env;
376 }
377
378 #if (SIZEOF_VOID_P != SIZEOF_SCMOBJ)
379 if (type & SCM_FUNCTYPE_TAILREC) {
380 switch (i) {
381 case 1:
382 return (*func)(eval_state);
383 case 2:
384 return (*func)(argbuf[0], eval_state);
385 case 3:
386 #if SCM_FUNCTYPE_MAND_MAX >= 1
387 return (*func)(argbuf[0], argbuf[1], eval_state);
388 #endif
389 case 4:
390 #if SCM_FUNCTYPE_MAND_MAX >= 2
391 return (*func)(argbuf[0], argbuf[1], argbuf[2], eval_state);
392 #endif
393 case 5:
394 #if SCM_FUNCTYPE_MAND_MAX >= 3
395 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3], eval_state);
396 #endif
397 case 6:
398 #if SCM_FUNCTYPE_MAND_MAX >= 4
399 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3], argbuf[4], eval_state);
400 #endif
401 case 7:
402 #if SCM_FUNCTYPE_MAND_MAX >= 5
403 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3], argbuf[4], argbuf[5], eval_state);
404 #endif
405 default:
406 SCM_NOTREACHED;
407 }
408 }
409 #endif /* (SIZEOF_VOID_P < SIZEOF_SCMOBJ) */
410
411 switch (i) {
412 case 0:
413 return (*func)();
414 case 1:
415 return (*func)(argbuf[0]);
416 case 2:
417 return (*func)(argbuf[0], argbuf[1]);
418 case 3:
419 #if SCM_FUNCTYPE_MAND_MAX >= 1
420 return (*func)(argbuf[0], argbuf[1], argbuf[2]);
421 #endif
422 case 4:
423 #if SCM_FUNCTYPE_MAND_MAX >= 2
424 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3]);
425 #endif
426 case 5:
427 #if SCM_FUNCTYPE_MAND_MAX >= 3
428 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3], argbuf[4]);
429 #endif
430 case 6:
431 #if SCM_FUNCTYPE_MAND_MAX >= 4
432 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3], argbuf[4], argbuf[5]);
433 #endif
434 case 7:
435 #if SCM_FUNCTYPE_MAND_MAX >= 5
436 return (*func)(argbuf[0], argbuf[1], argbuf[2], argbuf[3], argbuf[4], argbuf[5], argbuf[6]);
437 #endif
438
439 default:
440 SCM_NOTREACHED;
441 }
442 }
443
444 /*===========================================================================
445 S-Expression Evaluation
446 ===========================================================================*/
447 /*
448 * FIXME: I'm not sure what we should do with 'eval' to conform to following
449 * specification. See also 'rec-by-eval' of test-tail-rec.scm.
450 * -- YamaKen 2006-09-25
451 *
452 * R5RS: 3.5 Proper tail recursion
453 * > Certain built-in procedures are also required to perform tail calls. The
454 * > first argument passed to apply and to call-with-current-continuation, and
455 * > the second argument passed to call-with-values, must be called via a tail
456 * > call. Similarly, eval must evaluate its argument as if it were in tail
457 * > position within the eval procedure.
458 */
459 SCM_EXPORT ScmObj
scm_p_eval(ScmObj obj,ScmObj env)460 scm_p_eval(ScmObj obj, ScmObj env)
461 {
462 DECLARE_FUNCTION("eval", procedure_fixed_2);
463
464 ENSURE_VALID_ENV(env);
465
466 return scm_eval(obj, env);
467 }
468
469 SCM_EXPORT ScmObj
scm_eval(ScmObj obj,ScmObj env)470 scm_eval(ScmObj obj, ScmObj env)
471 {
472 ScmEvalState state;
473
474 #if SCM_STRICT_TOPLEVEL_DEFINITIONS
475 /* FIXME: temporary hack */
476 if (EQ(env, SCM_INTERACTION_ENV_INDEFINABLE)) {
477 env = SCM_INTERACTION_ENV;
478 SCM_EVAL_STATE_INIT1(state, env);
479 state.nest = SCM_NEST_COMMAND;
480 } else if (EQ(env, SCM_INTERACTION_ENV)) {
481 SCM_EVAL_STATE_INIT1(state, env);
482 state.nest = SCM_NEST_PROGRAM;
483 } else {
484 SCM_EVAL_STATE_INIT1(state, env);
485 }
486 #else
487 /* intentionally does not use SCM_EVAL_STATE_INIT() to avoid overhead */
488 state.env = env;
489 #endif
490
491 #if SCM_USE_BACKTRACE
492 scm_push_trace_frame(obj, env);
493 #endif
494
495 eval_loop:
496 if (IDENTIFIERP(obj)) {
497 obj = scm_symbol_value(obj, state.env);
498 } else if (CONSP(obj)) {
499 obj = call(CAR(obj), CDR(obj), &state, SCM_VALTYPE_NEED_EVAL);
500 if (state.ret_type == SCM_VALTYPE_NEED_EVAL) {
501 #if SCM_STRICT_TOPLEVEL_DEFINITIONS
502 if (state.nest == SCM_NEST_RETTYPE_BEGIN)
503 state.nest = SCM_NEST_COMMAND_OR_DEFINITION;
504 else
505 state.nest = SCM_NEST_COMMAND;
506 #endif
507 goto eval_loop;
508 }
509 }
510 #if SCM_STRICT_NULL_FORM
511 /* () is allowed by default for efficiency */
512 else if (NULLP(obj))
513 PLAIN_ERR("eval: () is not a valid R5RS form. use '() instead");
514 #endif
515 #if (SCM_USE_VECTOR && SCM_STRICT_VECTOR_FORM)
516 else if (VECTORP(obj))
517 PLAIN_ERR("eval: #() is not a valid R5RS form. use '#() instead");
518 #endif
519
520 #if SCM_USE_BACKTRACE
521 scm_pop_trace_frame();
522 #endif
523 return obj;
524 }
525
526 SCM_EXPORT ScmObj
scm_p_apply(ScmObj proc,ScmObj arg0,ScmObj rest,ScmEvalState * eval_state)527 scm_p_apply(ScmObj proc, ScmObj arg0, ScmObj rest, ScmEvalState *eval_state)
528 {
529 ScmQueue q;
530 ScmObj args, arg, last;
531 DECLARE_FUNCTION("apply", procedure_variadic_tailrec_2);
532
533 if (NULLP(rest)) {
534 args = last = arg0;
535 } else {
536 /* More than one argument given. */
537 args = LIST_1(arg0);
538 q = REF_CDR(args);
539 FOR_EACH_BUTLAST (arg, rest)
540 SCM_QUEUE_ADD(q, arg);
541 /* The last one is spliced. */
542 SCM_QUEUE_SLOPPY_APPEND(q, arg);
543 last = arg;
544 }
545
546 ENSURE_LIST(last);
547
548 /* Since any tail recursive procedures called here return a tail expression
549 * with SCM_VALTYPE_NEED_EVAL, evaluate such proc with call() does not
550 * break proper tail recursion of 'apply'. -- YamaKen 2006-09-25 */
551 return call(proc, args, eval_state, SCM_VALTYPE_AS_IS);
552 }
553
554 static ScmObj
map_eval(ScmObj args,scm_int_t * args_len,ScmObj env)555 map_eval(ScmObj args, scm_int_t *args_len, ScmObj env)
556 {
557 ScmQueue q;
558 ScmObj ret, elm, rest;
559 scm_int_t len;
560 DECLARE_INTERNAL_FUNCTION("(function call)");
561
562 if (NULLP(args)) {
563 *args_len = 0;
564 return SCM_NULL;
565 }
566
567 ret = SCM_NULL;
568 SCM_QUEUE_POINT_TO(q, ret);
569
570 len = 0;
571 FOR_EACH_PAIR (rest, args) {
572 len++;
573 elm = EVAL(CAR(rest), env);
574 CHECK_VALID_EVALED_VALUE(elm);
575 SCM_QUEUE_ADD(q, elm);
576 }
577 if (!NULLP(rest))
578 ERR_OBJ(SCM_ERRMSG_IMPROPER_ARGS, args);
579
580 *args_len = len;
581 return ret;
582 }
583
584 /*=======================================
585 R5RS : 6.5 Eval
586 =======================================*/
587 SCM_EXPORT ScmObj
scm_p_scheme_report_environment(ScmObj version)588 scm_p_scheme_report_environment(ScmObj version)
589 {
590 DECLARE_FUNCTION("scheme-report-environment", procedure_fixed_1);
591
592 ENSURE_INT(version);
593 if (SCM_INT_VALUE(version) != 5)
594 ERR_OBJ("version must be 5 but got", version);
595
596 #if SCM_STRICT_R5RS
597 ERR(SCM_ERRMSG_NON_R5RS_ENV);
598 #else
599 CDBG((SCM_DBG_COMPAT,
600 "scheme-report-environment: warning: " SCM_ERRMSG_NON_R5RS_ENV));
601 #endif
602
603 return SCM_R5RS_ENV;
604 }
605
606 SCM_EXPORT ScmObj
scm_p_null_environment(ScmObj version)607 scm_p_null_environment(ScmObj version)
608 {
609 DECLARE_FUNCTION("null-environment", procedure_fixed_1);
610
611 ENSURE_INT(version);
612 if (SCM_INT_VALUE(version) != 5)
613 ERR_OBJ("version must be 5 but got", version);
614
615 #if SCM_STRICT_R5RS
616 ERR(SCM_ERRMSG_NON_R5RS_ENV);
617 #else
618 CDBG((SCM_DBG_COMPAT,
619 "null-environment: warning: " SCM_ERRMSG_NON_R5RS_ENV));
620 #endif
621
622 return SCM_NULL_ENV;
623 }
624
625 SCM_EXPORT ScmObj
scm_p_interaction_environment(void)626 scm_p_interaction_environment(void)
627 {
628 DECLARE_FUNCTION("interaction-environment", procedure_fixed_0);
629
630 return SCM_INTERACTION_ENV;
631 }
632