[uim-commit] r2921 - in branches/r5rs/sigscheme: src test
yamaken at freedesktop.org
yamaken at freedesktop.org
Sat Jan 14 15:36:32 PST 2006
Author: yamaken
Date: 2006-01-14 15:36:15 -0800 (Sat, 14 Jan 2006)
New Revision: 2921
Modified:
branches/r5rs/sigscheme/src/config.h
branches/r5rs/sigscheme/src/env.c
branches/r5rs/sigscheme/src/sigschemeinternal.h
branches/r5rs/sigscheme/src/syntax.c
branches/r5rs/sigscheme/test/test-define.scm
branches/r5rs/sigscheme/test/unittest.scm
Log:
* This commit fix R5RS-incompatible internal definitions. But 'begin'
form still has an incompatibility
* sigscheme/src/config.h
- (SCM_STRICT_DEFINE_PLACEMENT): New macro
* sigscheme/src/sigschemeinternal.h
- (scm_toplevel_environmentp): New function decl
* sigscheme/src/env.c
- (scm_toplevel_environmentp): New function
* sigscheme/src/syntax.c
- (sym_define, syn_lambda, scm_init_syntax): Replace
SCM_STRICT_ARGCHECK with SCM_STRICT_DEFINE_PLACEMENT
- (scm_s_body):
* Ditto
* Simplify with strict define placement rule
- (define_internal):
* Replace NULLP() with scm_toplevel_environmentp()
* Cause an error if non-toplevel and SCM_STRICT_DEFINE_PLACEMENT
* sigscheme/test/unittest.scm
- Fix R5RS-incompatible define placement
* sigscheme/test/test-define.scm
- Fix and add tests for internal definition
Modified: branches/r5rs/sigscheme/src/config.h
===================================================================
--- branches/r5rs/sigscheme/src/config.h 2006-01-14 21:41:28 UTC (rev 2920)
+++ branches/r5rs/sigscheme/src/config.h 2006-01-14 23:36:15 UTC (rev 2921)
@@ -84,6 +84,7 @@
===========================================================================*/
#define SCM_STRICT_R5RS 0 /* use strict R5RS check */
#define SCM_STRICT_ARGCHECK 1 /* enable strict argument check */
+#define SCM_STRICT_DEFINE_PLACEMENT 1 /* enable strict check on internal definitions */
#define SCM_STRICT_ENCODING_CHECK 1 /* do all feasible encoding error checks */
#define SCM_ACCESSOR_ASSERT 0 /* enable strict type check with accessor */
#define SCM_USE_VALUECONS 1 /* use experimental values passing */
Modified: branches/r5rs/sigscheme/src/env.c
===================================================================
--- branches/r5rs/sigscheme/src/env.c 2006-01-14 21:41:28 UTC (rev 2920)
+++ branches/r5rs/sigscheme/src/env.c 2006-01-14 23:36:15 UTC (rev 2921)
@@ -98,6 +98,12 @@
/*=======================================
Function Implementations
=======================================*/
+scm_bool
+scm_toplevel_environmentp(ScmObj env)
+{
+ return NULLP(env);
+}
+
/**
* Construct new frame on an env
*
Modified: branches/r5rs/sigscheme/src/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/src/sigschemeinternal.h 2006-01-14 21:41:28 UTC (rev 2920)
+++ branches/r5rs/sigscheme/src/sigschemeinternal.h 2006-01-14 23:36:15 UTC (rev 2921)
@@ -474,6 +474,7 @@
void scm_finalize_symbol(void);
/* env.c */
+scm_bool scm_toplevel_environmentp(ScmObj env);
ScmObj scm_extend_environment(ScmObj formals, ScmObj actuals, ScmObj env);
ScmObj scm_replace_environment(ScmObj formals, ScmObj actuals, ScmObj env);
ScmObj scm_update_environment(ScmObj actuals, ScmObj env);
Modified: branches/r5rs/sigscheme/src/syntax.c
===================================================================
--- branches/r5rs/sigscheme/src/syntax.c 2006-01-14 21:41:28 UTC (rev 2920)
+++ branches/r5rs/sigscheme/src/syntax.c 2006-01-14 23:36:15 UTC (rev 2921)
@@ -55,7 +55,7 @@
Variable Declarations
=======================================*/
static ScmObj sym_else, sym_yields;
-#if SCM_STRICT_ARGCHECK
+#if SCM_STRICT_DEFINE_PLACEMENT
static ScmObj sym_define, syn_lambda;
#endif
@@ -78,7 +78,7 @@
sym_else = scm_intern("else");
sym_yields = scm_intern("=>");
-#if SCM_STRICT_ARGCHECK
+#if SCM_STRICT_DEFINE_PLACEMENT
sym_define = scm_intern("define");
scm_gc_protect_with_init(&syn_lambda,
scm_symbol_value(scm_intern("lambda"),
@@ -653,14 +653,14 @@
ScmObj
scm_s_body(ScmObj body, ScmEvalState *eval_state)
{
-#if SCM_STRICT_ARGCHECK
+#if SCM_STRICT_DEFINE_PLACEMENT
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 SCM_STRICT_DEFINE_PLACEMENT
if (NO_MORE_ARG(body)) {
eval_state->ret_type = SCM_VALTYPE_AS_IS;
return SCM_UNDEF;
@@ -706,33 +706,16 @@
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_state->env = scm_update_environment(actuals, env);
/* eval rest of the body */
- if (CONSP(body)) {
- FOR_EACH_BUTLAST (exp, body) {
- if (EQ(CAR(exp), sym_define))
- ERR_OBJ(ERRMSG_BAD_DEFINE_PLACEMENT, exp);
- EVAL(exp, env);
- }
- if (EQ(CAR(exp), sym_define))
- ERR_OBJ(ERRMSG_BAD_DEFINE_PLACEMENT, exp);
- } else {
- eval_state->ret_type = SCM_VALTYPE_AS_IS;
- }
- ASSERT_NO_MORE_ARG(body);
-
- eval_state->env = env;
- return exp;
-#else
- return scm_s_begin(body, eval_state);
#endif
+ return scm_s_begin(body, eval_state);
}
/*
@@ -1195,12 +1178,16 @@
ScmObj val;
val = EVAL(exp, env);
- if (NULLP(env)) { /* FIXME: env-implementation specific */
- /* given top-level environment */
+ if (scm_toplevel_environmentp(env)) {
SCM_SYMBOL_SET_VCELL(var, val);
} else {
- /* add val to the environment */
+#if SCM_STRICT_DEFINE_PLACEMENT
+ /* internal definitions are handled as a virtual letrec in
+ * scm_s_body() */
+ ERR(ERRMSG_BAD_DEFINE_PLACEMENT);
+#else
env = scm_add_environment(var, val, env);
+#endif
}
}
Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm 2006-01-14 21:41:28 UTC (rev 2920)
+++ branches/r5rs/sigscheme/test/test-define.scm 2006-01-14 23:36:15 UTC (rev 2921)
@@ -161,7 +161,7 @@
(assert-equal? (tn)
14
(let ((x 5))
- (+ (begin
+ (+ (let ()
(define (f)
(define x 6)
(+ x 3))
@@ -300,40 +300,41 @@
(f)))
(tn "internal defintions: non-beginning of block (in eval)")
-(assert-error (tn)
- (lambda ()
- (let ()
- (define foo 1)
- (set! foo 5)
- (eval '(define bar 2)
- (interaction-environment))
- (+ foo bar))))
-(assert-error (tn)
- (lambda ()
- (let* ()
- (define foo 1)
- (set! foo 5)
- (eval '(define bar 2)
- (interaction-environment))
- (+ foo bar))))
-(assert-error (tn)
- (lambda ()
- (letrec ()
- (define foo 1)
- (set! foo 5)
- (eval '(define bar 2)
- (interaction-environment))
- (+ foo bar))))
-(assert-error (tn)
- (lambda ()
- ((lambda ()
- (define foo 1)
- (set! foo 5)
- (begin
- (define bar 2))
- (+ foo bar)))))
-(assert-error (tn)
- (lambda ()
+(assert-equal? (tn)
+ 7
+ (let ()
+ (define foo 1)
+ (set! foo 5)
+ (eval '(define bar 2)
+ (interaction-environment))
+ (+ foo bar)))
+(assert-equal? (tn)
+ 7
+ (let* ()
+ (define foo 1)
+ (set! foo 5)
+ (eval '(define bar 2)
+ (interaction-environment))
+ (+ foo bar)))
+(assert-equal? (tn)
+ 7
+ (letrec ()
+ (define foo 1)
+ (set! foo 5)
+ (eval '(define bar 2)
+ (interaction-environment))
+ (+ foo bar)))
+(assert-equal? (tn)
+ 7
+ ((lambda ()
+ (define foo 1)
+ (set! foo 5)
+ (eval '(define bar 2)
+ (interaction-environment))
+ (+ foo bar))))
+(assert-equal? (tn)
+ 7
+ (let ()
(define (f)
(define foo 1)
(set! foo 5)
@@ -342,7 +343,7 @@
(+ foo bar))
(f)))
-;; As specified as follows in R5RS, definitions in 'do' syntax is invalid.
+;; As specified as follows in R5RS, definitions in following forms are invalid.
;;
;; 5.2 Definitions
;;
@@ -370,30 +371,46 @@
((= i 1) (+ x 3))
(begin
(define x 6)))))
-(assert-error (tn)
- (lambda ()
- (do ((i 0 (+ i 1)))
- ((= i 1) (+ x 3))
- (eval '(define x 6)
- (interaction-environment)))))
-
-(tn "defintion in begin")
(assert-equal? (tn)
- 15
- (let ((x 5))
- (+ (begin
- (define x 6)
- (+ x 3))
- x)))
+ 9
+ (do ((i 0 (+ i 1)))
+ ((= i 1) (+ x 3))
+ (eval '(define x 6)
+ (interaction-environment))))
+(tn "definition in if")
+(assert-error (tn)
+ (lambda ()
+ (if #t
+ (define x 6))))
+(assert-error (tn)
+ (lambda ()
+ (if #t
+ (begin
+ (define x 6)))))
(assert-equal? (tn)
- 7
- (let ()
- (begin
- (define foo 1)
- (set! foo 5)
- (define bar 2)
- (+ foo bar))))
+ 'x
+ (if #t
+ (eval '(define x 6)
+ (interaction-environment))))
+(tn "defintion in begin")
+;; FIXME
+;;(assert-equal? (tn)
+;; 15
+;; (let ((x 5))
+;; (+ (begin
+;; (define x 6)
+;; (+ x 3))
+;; x)))
+;;(assert-equal? (tn)
+;; 7
+;; (let ()
+;; (begin
+;; (define foo 1)
+;; (set! foo 5)
+;; (define bar 2)
+;; (+ foo bar))))
+
; set!
(define (set-dot a . b)
(set! b '(1 2))
Modified: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm 2006-01-14 21:41:28 UTC (rev 2920)
+++ branches/r5rs/sigscheme/test/unittest.scm 2006-01-14 23:36:15 UTC (rev 2921)
@@ -31,9 +31,10 @@
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(if (provided? "sigscheme")
- (begin
- (define cond-expand cond)
- (define sigscheme #t)))
+ (eval '(begin
+ (define cond-expand cond)
+ (define sigscheme #t))
+ (interaction-environment)))
(cond-expand
(sigscheme
More information about the uim-commit
mailing list