1
/*===========================================================================
3
* About : A Scheme environemnt implementation
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
===========================================================================*/
39
* SigScheme's environment object is a list formed as below.
41
* frame = (cons (var1 var2 var3 ...)
42
* (val1 val2 val3 ...))
43
* env = (frame1 frame2 frame3 ...)
45
* Other 2 forms are also used to handle dotted args.
47
* frame = (cons (var1 var2 var3 . rest1)
48
* (val1 val2 val3 var4 var5 ...))
51
* (val1 val2 val3 var4 var5 ...))
53
* In this case, rest1 is bound to (var4 var5 ...) and rest2 is bound to
54
* (val1 val2 val3 var4 var5 ...).
56
* The environment object should not be manipulated manually, to allow
57
* replacing with another implementation. Use the function interfaces.
59
* To ensure valid use of the environment objects is environment
60
* constructor's responsibility. i.e. Any lookup operations assume that the
61
* environment object is valid. To keep the assumption true, any environemnt
62
* object modification and injection from user code must be
63
* validated. Although the validation for the injection may cost high,
64
* ordinary code only use (interaction-environment) and other R5RS
65
* environment specifiers. Since these 'trusted' specifiers can cheaply be
66
* identified, the validation cost is also. The validation can reject any
67
* handmade invalid environment objects.
72
#include "sigscheme.h"
73
#include "sigschemeinternal.h"
75
/*=======================================
76
File Local Macro Definitions
77
=======================================*/
78
#define TRUSTED_ENVP(env) (EQ(env, SCM_INTERACTION_ENV) \
79
|| EQ(env, SCM_R5RS_ENV) \
80
|| EQ(env, SCM_NULL_ENV))
82
/*=======================================
83
File Local Type Definitions
84
=======================================*/
86
/*=======================================
88
=======================================*/
90
/*=======================================
91
File Local Function Declarations
92
=======================================*/
93
static scm_bool valid_framep(ScmObj frame);
95
/*=======================================
97
=======================================*/
99
scm_toplevel_environmentp(ScmObj env)
104
#if SCM_USE_HYGIENIC_MACRO
106
/* ScmPackedEnv is scm_int_t. */
108
SCM_EXPORT ScmPackedEnv
109
scm_pack_env(ScmObj env)
112
DECLARE_INTERNAL_FUNCTION("scm_env_depth");
114
depth = scm_length(env);
115
SCM_ASSERT(SCM_LISTLEN_PROPERP(depth));
121
scm_unpack_env(ScmPackedEnv packed, ScmObj context)
125
depth = scm_length(context);
126
while (depth-- > packed)
127
context = CDR(context);
133
lookup_n_frames(ScmObj id, scm_int_t n, ScmObj env)
138
SCM_ASSERT(ENVP(env));
139
ref = scm_lookup_frame(id, CAR(env));
140
if (ref != SCM_INVALID_REF)
144
return SCM_INVALID_REF;
149
* Resolves X in scm_unpack_env(XPENV, ENV), Y in ENV and tests
150
* whether they are bound to the same location. The parameters x and
151
* y are thus UNINTERCHANGEABLE.
153
* The pattern matcher must compare scm_wrap_identifier(x, xpenv) with
154
* y, but for performance we'd like to do that without actually
155
* allocating the wrapper. In the absence of syntax-case or
156
* comparable mechanisms allowing for unhygienic transforms, the
157
* binding frame of X and Y are always both contained in ENV, so we
158
* might as well require that ENV be the environment in which one of
159
* the operands (namely, Y) is to be looked up.
161
* But this is definitely an ugly interface, and also inconvenient
162
* because the function needs a different signature when unhygienic
163
* transforms are enabled. So, FIXME: is there a better way?
165
* Moving this to macro.c can be an option, but keep in mind some
166
* aspects are inherently tightly coupled with the lookup functions.
169
scm_identifierequalp(ScmObj x, ScmPackedEnv xpenv,
170
ScmObj y, ScmPackedEnv penv, ScmObj env)
174
SCM_ASSERT(xpenv <= penv);
175
SCM_ASSERT(SCM_PENV_EQ(scm_pack_env(env), penv));
177
while (penv-- > xpenv) {
178
if (scm_lookup_frame(y, CAR(env)) != SCM_INVALID_REF)
184
yloc = scm_lookup_environment(y, env);
185
if (yloc != SCM_INVALID_REF)
186
return (scm_lookup_environment(x, env) == yloc);
187
if (scm_lookup_environment(x, env) != SCM_INVALID_REF)
189
return EQ(SCM_UNWRAP_KEYWORD(x), SCM_UNWRAP_KEYWORD(y));
193
* Returns an identifier that is bound to the same location as ID
194
* within ENV (whose packed representation is DEPTH), but is not eq?
198
scm_wrap_identifier(ScmObj id, ScmPackedEnv depth, ScmObj env)
202
SCM_ASSERT(IDENTIFIERP(id));
203
SCM_ASSERT(depth == scm_pack_env(env));
205
if (FARSYMBOLP(id)) {
206
/* Try to reduce lookup overhead. */
207
id_depth = SCM_FARSYMBOL_ENV(id);
208
SCM_ASSERT(id_depth <= depth);
209
if (lookup_n_frames(id, depth - id_depth, env) == SCM_INVALID_REF) {
210
/* ID hasn't been bound since it was captured. */
211
return MAKE_FARSYMBOL(SCM_FARSYMBOL_SYM(id), id_depth);
214
return MAKE_FARSYMBOL(id, depth);
216
#endif /* SCM_USE_HYGIENIC_MACRO */
219
* Construct a new frame on an env
221
* @a formals and @a actuals must be valid.
223
* @param formals Symbol list as variable names of new frame. It accepts dotted
224
* list to handle function arguments directly.
225
* @param actuals Arbitrary Scheme object list as values of new frame.
230
scm_extend_environment(ScmObj formals, ScmObj actuals, ScmObj env)
233
DECLARE_INTERNAL_FUNCTION("scm_extend_environment");
235
SCM_ASSERT(scm_valid_environment_extensionp(formals, actuals));
236
SCM_ASSERT(VALID_ENVP(env));
238
frame = CONS(formals, actuals);
239
return CONS(frame, env);
243
* Replace entire content of recentmost frame of an env
245
* The environment must be replaced with returned one in caller side even if
246
* this implementation returns identical to the one passed. This rule is
247
* required to be compatible with future alternative implementations.
250
scm_replace_environment(ScmObj formals, ScmObj actuals, ScmObj env)
253
DECLARE_INTERNAL_FUNCTION("scm_replace_environment");
255
SCM_ASSERT(scm_valid_environment_extensionp(formals, actuals));
256
SCM_ASSERT(VALID_ENVP(env));
257
SCM_ASSERT(CONSP(env));
260
SET_CAR(frame, formals);
261
SET_CDR(frame, actuals);
267
* Replace all actuals of recentmost frame of an env
269
* The environment must be replaced with returned one in caller side even if
270
* this implementation returns identical to the one passed. This rule is
271
* required to be compatible with future alternative implementations.
274
scm_update_environment(ScmObj actuals, ScmObj env)
277
DECLARE_INTERNAL_FUNCTION("scm_update_environment");
279
SCM_ASSERT(VALID_ENVP(env));
280
SCM_ASSERT(CONSP(env));
283
SCM_ASSERT(scm_valid_environment_extensionp(CAR(frame), actuals));
284
SET_CDR(frame, actuals);
289
/** Add a binding to recentmost frame of an env */
291
scm_add_environment(ScmObj var, ScmObj val, ScmObj env)
293
ScmObj frame, formals, actuals;
294
DECLARE_INTERNAL_FUNCTION("scm_add_environment");
296
SCM_ASSERT(IDENTIFIERP(var));
297
SCM_ASSERT(VALID_ENVP(env));
299
/* add (var, val) pair to recentmost frame of the env */
301
frame = CONS(LIST_1(var), LIST_1(val));
303
} else if (CONSP(env)) {
305
formals = CONS(var, CAR(frame));
306
actuals = CONS(val, CDR(frame));
307
SET_CAR(frame, formals);
308
SET_CDR(frame, actuals);
316
* Lookup a variable of an env
318
* @return Reference to the variable. SCM_INVALID_REF if not found.
321
scm_lookup_environment(ScmObj var, ScmObj env)
325
#if SCM_USE_HYGIENIC_MACRO
326
scm_int_t depth, id_depth;
328
#endif /* SCM_USE_HYGIENIC_MACRO */
329
DECLARE_INTERNAL_FUNCTION("scm_lookup_environment");
331
SCM_ASSERT(IDENTIFIERP(var));
332
SCM_ASSERT(VALID_ENVP(env));
334
/* lookup in frames */
335
#if SCM_USE_HYGIENIC_MACRO
339
for (; !NULLP(env); env = CDR(env)) {
341
ref = scm_lookup_frame(var, frame);
342
if (ref != SCM_INVALID_REF)
344
#if SCM_USE_HYGIENIC_MACRO
348
SCM_ASSERT(NULLP(env));
350
#if SCM_USE_HYGIENIC_MACRO
351
if (FARSYMBOLP(var)) {
353
id_depth = SCM_FARSYMBOL_ENV(var);
354
if (id_depth > depth)
355
scm_macro_bad_scope(var);
356
for (i = depth - id_depth; i--; )
357
env_save = CDR(env_save);
358
ref = lookup_n_frames(SCM_FARSYMBOL_SYM(var),
360
SCM_ASSERT(ref != SCM_INVALID_REF || SYMBOLP(SCM_FARSYMBOL_SYM(var)));
365
return SCM_INVALID_REF;
368
/** Lookup a variable in a frame */
370
scm_lookup_frame(ScmObj var, ScmObj frame)
374
DECLARE_INTERNAL_FUNCTION("scm_lookup_frame");
376
SCM_ASSERT(IDENTIFIERP(var));
377
SCM_ASSERT(valid_framep(frame));
379
for (formals = CAR(frame), actuals = REF_CDR(frame);
381
formals = CDR(formals), actuals = REF_CDR(DEREF(actuals)))
383
if (EQ(var, CAR(formals)))
384
return REF_CAR(DEREF(actuals));
387
if (EQ(var, formals))
390
return SCM_INVALID_REF;
394
scm_symbol_value(ScmObj var, ScmObj env)
398
DECLARE_INTERNAL_FUNCTION("scm_symbol_value");
400
SCM_ASSERT(IDENTIFIERP(var));
402
ref = scm_lookup_environment(var, env);
403
if (ref != SCM_INVALID_REF) {
404
/* Found in the environment. Since scm_s_body() may produce unbound
405
* variables as internal definitions, subsequent error check is
409
/* Fallback to top-level binding. */
410
#if SCM_USE_HYGIENIC_MACRO
412
var = SCM_FARSYMBOL_SYM(var);
413
SCM_ASSERT(SYMBOLP(var));
415
val = SCM_SYMBOL_VCELL(var);
418
if (EQ(val, SCM_UNBOUND))
419
ERR_OBJ("unbound variable", var);
428
scm_valid_environmentp(ScmObj env)
431
DECLARE_INTERNAL_FUNCTION("scm_valid_environmentp");
433
if (TRUSTED_ENVP(env))
437
* The env is extended and untrusted. Since this case rarely occurs in
438
* ordinary codes, the expensive validation cost is acceptable.
441
if (!PROPER_LISTP(env))
443
for (rest = env; !NULLP(rest); rest = CDR(rest)) {
445
if (!valid_framep(frame))
453
valid_framep(ScmObj frame)
455
ScmObj formals, actuals;
456
DECLARE_INTERNAL_FUNCTION("valid_framep");
459
formals = CAR(frame);
460
actuals = CDR(frame);
461
if (scm_valid_environment_extensionp(formals, actuals))
468
scm_valid_environment_extensionp(ScmObj formals, ScmObj actuals)
470
scm_int_t formals_len, actuals_len;
472
formals_len = scm_validate_formals(formals);
473
actuals_len = scm_validate_actuals(actuals);
474
return scm_valid_environment_extension_lengthp(formals_len, actuals_len);
477
/* formals_len must be validated by scm_validate_formals() prior to here */
479
scm_valid_environment_extension_lengthp(scm_int_t formals_len,
480
scm_int_t actuals_len)
482
if (SCM_LISTLEN_ERRORP(formals_len))
484
if (SCM_LISTLEN_DOTTEDP(formals_len)) {
485
formals_len = SCM_LISTLEN_DOTTED(formals_len);
486
if (SCM_LISTLEN_PROPERP(actuals_len))
487
return (formals_len <= actuals_len);
489
/* (lambda args (set-cdr! args #t) args) */
490
if (SCM_LISTLEN_DOTTEDP(actuals_len))
491
return (formals_len <= SCM_LISTLEN_DOTTED(actuals_len));
493
/* (lambda args (set-cdr! args args) args) */
494
if (SCM_LISTLEN_CIRCULARP(actuals_len)) /* always true */
497
return (formals_len == actuals_len);
501
scm_validate_formals(ScmObj formals)
503
#if SCM_STRICT_ARGCHECK
505
DECLARE_INTERNAL_FUNCTION("scm_validate_formals");
508
* SigScheme does not perform the check for duplicate variable name in
509
* formals. It is an user's responsibility.
511
* R5RS: 4.1.4 Procedures
512
* It is an error for a <variable> to appear more than once in <formals>.
515
/* This loop goes infinite if the formals is circular. SigSchme expects
516
* that user codes are sane here. */
517
for (len = 0; CONSP(formals); formals = CDR(formals), len++) {
518
if (!IDENTIFIERP(CAR(formals)))
519
return SCM_LISTLEN_ENCODE_ERROR(len);
523
/* dotted list allowed */
524
if (IDENTIFIERP(formals))
525
return SCM_LISTLEN_ENCODE_DOTTED(len);
526
return SCM_LISTLEN_ENCODE_ERROR(len);
528
/* Crashless loose validation:
529
* Regard any non-list object as symbol. Since the lookup operation search
530
* for a variable by EQ, this is safe although loosely allows
531
* R5RS-incompatible code. */
532
return scm_finite_length(formals);
537
scm_validate_actuals(ScmObj actuals)
541
#if SCM_STRICT_ARGCHECK
542
len = scm_length(actuals);
544
/* Crashless loose validation:
545
* This loop goes infinite if the formals is circular. SigSchme expects
546
* that user codes are sane here. */
547
len = scm_finite_length(actuals);
549
if (SCM_LISTLEN_DOTTEDP(len))
550
return SCM_LISTLEN_ENCODE_ERROR(len);
added
removed
sigscheme/src/env.c
