[uim-commit] r2908 - in branches/r5rs/sigscheme: src test
yamaken at freedesktop.org
yamaken at freedesktop.org
Sat Jan 14 05:00:00 PST 2006
Author: yamaken
Date: 2006-01-14 04:59:56 -0800 (Sat, 14 Jan 2006)
New Revision: 2908
Modified:
branches/r5rs/sigscheme/src/eval.c
branches/r5rs/sigscheme/src/operations-srfi2.c
branches/r5rs/sigscheme/src/operations-srfi34.c
branches/r5rs/sigscheme/src/operations-srfi8.c
branches/r5rs/sigscheme/src/sigscheme.c
branches/r5rs/sigscheme/src/sigschemeinternal.h
branches/r5rs/sigscheme/src/syntax.c
branches/r5rs/sigscheme/test/test-define.scm
Log:
* This commit add strict form validation for internal definitions
* sigscheme/src/sigschemeinternal.h
- (scm_s_body): New function decl
* sigscheme/src/syntax.c
- (ERRMSG_NON_BEGINNING_INTERNAL_DEFINITION): New macro
- (scm_sym_define, scm_syn_lambda): New variable
- (scm_s_body): New function
- (scm_s_let, scm_s_letstar, scm_s_letrec): Replace scm_s_begin()
with scm_s_body()
- (define_internal): Simplify
* sigscheme/src/sigscheme.c
- (scm_sym_define, scm_syn_lambda): New extern decl
- (scm_initialize_internal): Add initialization for the variables
* sigscheme/src/eval.c
- (call_closure): Replace scm_s_begin() with scm_s_body()
* sigscheme/src/operations-srfi2.c
- (scm_s_srfi2_and_letstar): Ditto
* sigscheme/src/operations-srfi8.c
- (scm_s_srfi8_receive): Ditto
* sigscheme/src/operations-srfi34.c
- (guard_body): Ditto
* sigscheme/test/test-define.scm
- Fix non-beginning internal definitions for lambda form
Modified: branches/r5rs/sigscheme/src/eval.c
===================================================================
--- branches/r5rs/sigscheme/src/eval.c 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/eval.c 2006-01-14 12:59:56 UTC (rev 2908)
@@ -254,7 +254,7 @@
}
eval_state->ret_type = SCM_RETTYPE_NEED_EVAL;
- return scm_s_begin(body, eval_state);
+ return scm_s_body(body, eval_state);
err_improper:
ERR_OBJ("unmatched number or improper args", args);
Modified: branches/r5rs/sigscheme/src/operations-srfi2.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi2.c 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/operations-srfi2.c 2006-01-14 12:59:56 UTC (rev 2908)
@@ -122,7 +122,7 @@
eval_state->env = env;
- return scm_s_begin(body, eval_state);
+ return scm_s_body(body, eval_state);
err:
ERR_OBJ("invalid claws form", claws);
Modified: branches/r5rs/sigscheme/src/operations-srfi34.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi34.c 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/operations-srfi34.c 2006-01-14 12:59:56 UTC (rev 2908)
@@ -389,8 +389,9 @@
/* evaluate the body */
lex_eval_state.env = lex_env;
lex_eval_state.ret_type = SCM_RETTYPE_NEED_EVAL;
- result = scm_s_begin(body, &lex_eval_state); /* always NEED_EVAL */
- result = EVAL(result, lex_env);
+ result = scm_s_body(body, &lex_eval_state);
+ if (lex_eval_state.ret_type == SCM_RETTYPE_NEED_EVAL)
+ result = EVAL(result, lex_env);
eval_state->ret_type = SCM_RETTYPE_AS_IS;
scm_call_continuation(guard_k, delay(result, lex_env));
Modified: branches/r5rs/sigscheme/src/operations-srfi8.c
===================================================================
--- branches/r5rs/sigscheme/src/operations-srfi8.c 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/operations-srfi8.c 2006-01-14 12:59:56 UTC (rev 2908)
@@ -108,5 +108,5 @@
ERR_OBJ("unmatched number of args for multiple values", actuals);
eval_state->env = env = scm_extend_environment(formals, actuals, env);
- return scm_s_begin(body, eval_state);
+ return scm_s_body(body, eval_state);
}
Modified: branches/r5rs/sigscheme/src/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/src/sigscheme.c 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/sigscheme.c 2006-01-14 12:59:56 UTC (rev 2908)
@@ -66,6 +66,8 @@
ScmObj scm_sym_unquote, scm_sym_unquote_splicing;
ScmObj scm_sym_else, scm_sym_yields;
+extern ScmObj scm_sym_define, scm_syn_lambda;
+
/* canonical internal encoding for identifiers */
ScmCharCodec *scm_identifier_codec;
@@ -167,6 +169,11 @@
scm_sym_else = scm_intern("else");
scm_sym_yields = scm_intern("=>");
+#if SCM_STRICT_ARGCHECK
+ /* syntax.c */
+ scm_sym_define = scm_intern("define");
+#endif
+
scm_gc_protect_with_init(&features, SCM_NULL);
/*=======================================================================
@@ -185,6 +192,14 @@
#endif
/*=======================================================================
+ Predefined Objects
+ =======================================================================*/
+#if SCM_STRICT_ARGCHECK
+ scm_syn_lambda
+ = scm_symbol_value(scm_intern("lambda"), SCM_INTERACTION_ENV);
+#endif
+
+ /*=======================================================================
Fixing up
=======================================================================*/
/* to evaluate SigScheme-dependent codes conditionally */
Modified: branches/r5rs/sigscheme/src/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/src/sigschemeinternal.h 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/sigschemeinternal.h 2006-01-14 12:59:56 UTC (rev 2908)
@@ -496,6 +496,7 @@
ScmObj scm_eval(ScmObj obj, ScmObj env);
/* syntax.c */
+ScmObj scm_s_body(ScmObj body, ScmEvalState *eval_state);
ScmObj scm_s_cond_internal(ScmObj args, ScmObj case_key,
ScmEvalState *eval_state);
Modified: branches/r5rs/sigscheme/src/syntax.c
===================================================================
--- branches/r5rs/sigscheme/src/syntax.c 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/src/syntax.c 2006-01-14 12:59:56 UTC (rev 2908)
@@ -49,10 +49,15 @@
/*=======================================
File Local Macro Declarations
=======================================*/
+#define ERRMSG_NON_BEGINNING_INTERNAL_DEFINITION \
+ "internal definition must not appear in a middle of <body>"
/*=======================================
Variable Declarations
=======================================*/
+#if SCM_STRICT_ARGCHECK
+ScmObj scm_sym_define, scm_syn_lambda;
+#endif
/*=======================================
File Local Function Declarations
@@ -626,6 +631,95 @@
/*===========================================================================
R5RS : 4.2 Derived expression types : 4.2.2 Binding constructs
===========================================================================*/
+/* <body> part of let, let*, letrec and lambda. This function performs strict
+ * form validation for internal definitions as specified in R5RS (5.2.2
+ * Internal definitions). */
+/* TODO: Reform as a read-time syntax translator */
+ScmObj
+scm_s_body(ScmObj body, ScmEvalState *eval_state)
+{
+#if SCM_STRICT_ARGCHECK
+ ScmQueue def_expq;
+ ScmObj env, formals, actuals, def_exps, exp, var, sym;
+ ScmObj lambda_formals, lambda_body;
+#endif
+ DECLARE_INTERNAL_FUNCTION("(body)" /* , syntax_variadic_tailrec_0 */);
+
+#if SCM_STRICT_ARGCHECK
+ if (NO_MORE_ARG(body)) {
+ eval_state->ret_type = SCM_RETTYPE_AS_IS;
+ return SCM_UNDEF;
+ }
+
+ /* extend env by placeholder frame for subsequent internal definitions */
+ env = scm_extend_environment(SCM_NULL, SCM_NULL, eval_state->env);
+
+ /* collect internal definitions */
+ def_exps = formals = actuals = SCM_NULL;
+ SCM_QUEUE_POINT_TO(def_expq, def_exps);
+ while (CONSP(body)) {
+ exp = CAR(body);
+ if (!CONSP(exp) || (sym = POP(exp), !EQ(sym, scm_sym_define)))
+ break;
+ POP(body);
+
+ var = MUST_POP_ARG(exp);
+ if (SYMBOLP(var)) {
+ /* (define <variable> <expression>) */
+ if (!LIST_1_P(exp))
+ ERR_OBJ("exactly 1 arg required but got", exp);
+ exp = CAR(exp);
+ } else if (CONSP(var)) {
+ /* (define (<variable> . <formals>) <body>) */
+ sym = CAR(var);
+ lambda_formals = CDR(var);
+ lambda_body = exp;
+
+ ENSURE_SYMBOL(sym);
+ var = sym;
+ exp = CONS(scm_syn_lambda, CONS(lambda_formals, lambda_body));
+ } else {
+ ERR_OBJ("syntax error", var);
+ }
+ formals = CONS(var, formals);
+ actuals = CONS(SCM_UNBOUND, actuals);
+ SCM_QUEUE_ADD(def_expq, exp);
+ }
+
+ /* inject the unbound variables into the frame to make the variable
+ * references invalid through the evaluation */
+ env = scm_replace_environment(formals, actuals, env);
+
+ /* eval the definitions and fill the placeholder frame with the results */
+ exp = SCM_UNDEF;
+ actuals = SCM_NULL;
+ FOR_EACH (exp, def_exps) {
+ exp = EVAL(exp, env);
+ actuals = CONS(exp, actuals);
+ }
+ env = scm_update_environment(actuals, env);
+
+ /* eval rest of the body */
+ if (CONSP(body)) {
+ FOR_EACH_BUTLAST (exp, body) {
+ if (EQ(CAR(exp), scm_sym_define))
+ ERR_OBJ(ERRMSG_NON_BEGINNING_INTERNAL_DEFINITION, exp);
+ EVAL(exp, env);
+ }
+ if (EQ(CAR(exp), scm_sym_define))
+ ERR_OBJ(ERRMSG_NON_BEGINNING_INTERNAL_DEFINITION, exp);
+ } else {
+ eval_state->ret_type = SCM_RETTYPE_AS_IS;
+ }
+ ASSERT_NO_MORE_ARG(body);
+
+ eval_state->env = env;
+ return exp;
+#else
+ return scm_s_begin(body, eval_state);
+#endif
+}
+
/*
* FIXME:
* - Write the test for the named let spec:
@@ -706,7 +800,7 @@
define_internal(named_let_sym, proc, env);
}
- return scm_s_begin(body, eval_state);
+ return scm_s_body(body, eval_state);
}
ScmObj
@@ -749,7 +843,7 @@
eval_state->env = env;
- return scm_s_begin(body, eval_state);
+ return scm_s_body(body, eval_state);
err:
ERR_OBJ("invalid bindings form", bindings);
@@ -796,7 +890,7 @@
eval_state->env
= scm_replace_environment(formals, actuals, eval_state->env);
- return scm_s_begin(body, eval_state);
+ return scm_s_body(body, eval_state);
err:
ERR_OBJ("invalid bindings form", bindings);
@@ -1085,13 +1179,13 @@
{
ScmObj val;
- if (NULLP(env)) {
+ val = EVAL(exp, env);
+ if (NULLP(env)) { /* FIXME: env-implementation specific */
/* given top-level environment */
- val = EVAL(exp, env);
SCM_SYMBOL_SET_VCELL(var, val);
} else {
/* add val to the environment */
- env = scm_add_environment(var, EVAL(exp, env), env);
+ env = scm_add_environment(var, val, env);
}
}
Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm 2006-01-14 12:46:51 UTC (rev 2907)
+++ branches/r5rs/sigscheme/test/test-define.scm 2006-01-14 12:59:56 UTC (rev 2908)
@@ -242,18 +242,19 @@
(+ foo bar))))
(assert-error (tn)
(lambda ()
- (lambda ()
- (define foo 1)
- (set! foo 5)
- (define bar 2)
- (+ foo bar))))
+ ((lambda ()
+ (define foo 1)
+ (set! foo 5)
+ (define bar 2)
+ (+ foo bar)))))
(assert-error (tn)
(lambda ()
(define (f)
(define foo 1)
(set! foo 5)
(define bar 2)
- (+ foo bar))))
+ (+ foo bar))
+ (f)))
; set!
(define (set-dot a . b)
More information about the uim-commit
mailing list