[uim-commit] r2923 - in branches/r5rs/sigscheme: src test
yamaken at freedesktop.org
yamaken at freedesktop.org
Sat Jan 14 17:21:52 PST 2006
Author: yamaken
Date: 2006-01-14 17:21:01 -0800 (Sat, 14 Jan 2006)
New Revision: 2923
Modified:
branches/r5rs/sigscheme/src/syntax.c
branches/r5rs/sigscheme/test/test-define.scm
Log:
* sigscheme/src/syntax.c
- (sym_begin): New static variable
- (scm_init_syntax): Add initialization for sym_begin
- (filter_definitions): New static function
- (scm_s_body): Split off filter_definitions() and support 'begin'
properly
* sigscheme/test/test-define.scm
- Fix broken tests
- Add tests for internal definition in 'begin'
- All tests are passed
Modified: branches/r5rs/sigscheme/src/syntax.c
===================================================================
--- branches/r5rs/sigscheme/src/syntax.c 2006-01-14 23:51:13 UTC (rev 2922)
+++ branches/r5rs/sigscheme/src/syntax.c 2006-01-15 01:21:01 UTC (rev 2923)
@@ -56,12 +56,14 @@
=======================================*/
static ScmObj sym_else, sym_yields;
#if SCM_STRICT_DEFINE_PLACEMENT
-static ScmObj sym_define, syn_lambda;
+static ScmObj sym_define, sym_begin, syn_lambda;
#endif
/*=======================================
File Local Function Declarations
=======================================*/
+static ScmObj filter_definitions(ScmObj body, ScmObj *formals, ScmObj *actuals,
+ ScmQueue *def_expq);
static void define_internal(ScmObj var, ScmObj exp, ScmObj env);
/* Quasiquotation. */
@@ -80,6 +82,7 @@
sym_yields = scm_intern("=>");
#if SCM_STRICT_DEFINE_PLACEMENT
sym_define = scm_intern("define");
+ sym_begin = scm_intern("begin");
scm_gc_protect_with_init(&syn_lambda,
scm_symbol_value(scm_intern("lambda"),
SCM_INTERACTION_ENV));
@@ -646,6 +649,55 @@
/*===========================================================================
R5RS : 4.2 Derived expression types : 4.2.2 Binding constructs
===========================================================================*/
+#if SCM_STRICT_DEFINE_PLACEMENT
+static ScmObj
+filter_definitions(ScmObj body, ScmObj *formals, ScmObj *actuals,
+ ScmQueue *def_expq)
+{
+ ScmObj exp, var, sym, begin_rest, lambda_formals, lambda_body;
+ DECLARE_INTERNAL_FUNCTION("(body)");
+
+ for (; CONSP(body); POP(body)) {
+ exp = CAR(body);
+ if (!CONSP(exp))
+ break;
+ sym = POP(exp);
+ if (EQ(sym, sym_begin)) {
+ begin_rest = filter_definitions(exp, formals, actuals, def_expq);
+ if (CONSP(begin_rest))
+ return CONS(CONS(sym_begin, begin_rest), CDR(body));
+ ASSERT_NO_MORE_ARG(begin_rest);
+ } else if (EQ(sym, sym_define)) {
+ 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(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);
+ } else {
+ break;
+ }
+ }
+
+ return body;
+}
+#endif
+
/* <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). */
@@ -655,8 +707,7 @@
{
#if SCM_STRICT_DEFINE_PLACEMENT
ScmQueue def_expq;
- ScmObj env, formals, actuals, def_exps, exp, var, sym;
- ScmObj lambda_formals, lambda_body;
+ ScmObj env, formals, actuals, def_exps, exp;
#endif
DECLARE_INTERNAL_FUNCTION("(body)" /* , syntax_variadic_tailrec_0 */);
@@ -672,35 +723,8 @@
/* 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, sym_define)))
- break;
- POP(body);
+ body = filter_definitions(body, &formals, &actuals, &def_expq);
- 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(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);
Modified: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm 2006-01-14 23:51:13 UTC (rev 2922)
+++ branches/r5rs/sigscheme/test/test-define.scm 2006-01-15 01:21:01 UTC (rev 2923)
@@ -33,7 +33,7 @@
(load "./test/unittest.scm")
(define tn test-name)
-(define *test-track-progress* #t)
+(define *test-track-progress* #f)
; invalid form
(assert-error "define invalid form #1"
@@ -428,7 +428,7 @@
(assert-equal? (tn)
3
(let ()
- (lambda (f)
+ (define (f)
(begin
(define foo 1)
(define bar 2)
@@ -478,7 +478,7 @@
(assert-equal? (tn)
3
(let ()
- (lambda (f)
+ (define (f)
(begin
(define foo 4)
(define bar 5))
@@ -487,47 +487,49 @@
(define bar 2)
(+ foo bar)))
(f)))
-(tn "definition in invalid sequencial begin")
+(tn "definition in sequencial nested begin")
(assert-equal? (tn)
3
(let ()
(begin
(define foo 4)
- (define bar 5)
- (set! foo 3))
+ (define bar 5))
(begin
- (define foo 1)
- (define bar 2)
+ (define foo 6)
+ (begin
+ (define foo 1)
+ (define bar 2))
(+ foo bar))))
(assert-equal? (tn)
3
(let* ()
(begin
(define foo 4)
- (define bar 5)
- (set! foo 3))
+ (define bar 5))
(begin
- (define foo 1)
- (define bar 2)
+ (define foo 6)
+ (begin
+ (define foo 1)
+ (define bar 2))
(+ foo bar))))
(assert-equal? (tn)
3
(letrec ()
(begin
(define foo 4)
- (define bar 5)
- (set! foo 3))
+ (define bar 5))
(begin
- (define foo 1)
- (define bar 2)
+ (define foo 6)
+ (begin
+ (define foo 1)
+ (define bar 2))
(+ foo bar))))
(assert-equal? (tn)
3
((lambda ()
(begin
(define foo 4)
- (define bar 5)
- (set! foo 3))
+ (define bar 5))
(begin
(define foo 1)
(define bar 2)
@@ -535,16 +537,75 @@
(assert-equal? (tn)
3
(let ()
- (lambda (f)
+ (define (f)
(begin
(define foo 4)
+ (define bar 5))
+ (begin
+ (define foo 6)
+ (begin
+ (define foo 1)
+ (define bar 2))
+ (+ foo bar)))
+ (f)))
+(tn "definition in invalid sequencial begin")
+(assert-error (tn)
+ (lambda ()
+ (let ()
+ (begin
+ (define foo 4)
(define bar 5)
(set! foo 3))
(begin
(define foo 1)
(define bar 2)
- (+ foo bar)))
- (f)))
+ (+ foo bar)))))
+(assert-error (tn)
+ (lambda ()
+ (let* ()
+ (begin
+ (define foo 4)
+ (define bar 5)
+ (set! foo 3))
+ (begin
+ (define foo 1)
+ (define bar 2)
+ (+ foo bar)))))
+(assert-error (tn)
+ (lambda ()
+ (letrec ()
+ (begin
+ (define foo 4)
+ (define bar 5)
+ (set! foo 3))
+ (begin
+ (define foo 1)
+ (define bar 2)
+ (+ foo bar)))))
+(assert-error (tn)
+ (lambda ()
+ ((lambda ()
+ (begin
+ (define foo 4)
+ (define bar 5)
+ (set! foo 3))
+ (begin
+ (define foo 1)
+ (define bar 2)
+ (+ foo bar))))))
+(assert-error (tn)
+ (lambda ()
+ (let ()
+ (define (f)
+ (begin
+ (define foo 4)
+ (define bar 5)
+ (set! foo 3))
+ (begin
+ (define foo 1)
+ (define bar 2)
+ (+ foo bar)))
+ (f))))
; set!
(define (set-dot a . b)
More information about the uim-commit
mailing list