From ced8edb0f9545e7e37ec62cf7ab6c0c1c66fe1db Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 8 Nov 2003 08:11:14 +0000 Subject: [PATCH] * libguile/eval.c (s_missing_body_expression): New static identifier. (s_body): Removed. (scm_m_expand_body): Fixed core dump when passing a body with defines, but without expressions (see additions to syntax.test). Use ASSERT_SYNTAX to signal syntax errors. * test-suite/tests/syntax.test (exception:missing-body-expr): New. Renamed section 'define' to 'top-level define' and added a new section 'internal define' with some tests. --- libguile/ChangeLog | 10 +++++++ libguile/eval.c | 13 ++++++--- test-suite/ChangeLog | 7 +++++ test-suite/tests/syntax.test | 51 +++++++++++++++++++++++++++++++++--- 4 files changed, 75 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cab50b9c2..64c294fde 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2003-11-08 Dirk Herrmann + + * eval.c (s_missing_body_expression): New static identifier. + + (s_body): Removed. + + (scm_m_expand_body): Fixed core dump when passing a body with + defines, but without expressions (see additions to syntax.test). + Use ASSERT_SYNTAX to signal syntax errors. + 2003-11-02 Dirk Herrmann * eval.c (canonicalize_define): New static helper function. diff --git a/libguile/eval.c b/libguile/eval.c index e86b8e9d0..266066ef7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -114,6 +114,12 @@ static const char s_expression[] = "Missing or extra expression in"; * context, a 'Missing expression' error is signalled. */ static const char s_missing_expression[] = "Missing expression in"; +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. If a body with an empty sequence of + * expressions is detected, a 'Missing body expression' error is signalled. + */ +static const char s_missing_body_expression[] = "Missing body expression in"; + /* If a form is detected that holds more expressions than are allowed in that * context, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; @@ -408,7 +414,6 @@ SCM_REC_MUTEX (source_mutex); static const char s_test[] = "bad test"; -static const char s_body[] = "bad body"; static const char s_bindings[] = "bad bindings"; static const char s_duplicate_bindings[] = "duplicate bindings"; static const char s_variable[] = "bad variable"; @@ -1826,7 +1831,6 @@ SCM scm_m_expand_body (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), defs = SCM_EOL; - char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2; while (SCM_NIMP (x)) { @@ -1861,6 +1865,10 @@ scm_m_expand_body (SCM xorig, SCM env) } } + /* FIXME: xorig is already partially memoized and does not hold information + * about the file location. */ + ASSERT_SYNTAX (SCM_CONSP (x), s_missing_body_expression, xorig); + if (!SCM_NULLP (defs)) { SCM rvars, inits, body, letrec; @@ -1873,7 +1881,6 @@ scm_m_expand_body (SCM xorig, SCM env) } else { - SCM_ASSYNT (SCM_CONSP (x), s_body, what); SCM_SETCAR (xorig, SCM_CAR (x)); SCM_SETCDR (xorig, SCM_CDR (x)); } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0367d4da9..bc8597f7e 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2003-11-08 Dirk Herrmann + + * tests/syntax.test (exception:missing-body-expr): New. + + Renamed section 'define' to 'top-level define' and added a new + section 'internal define' with some tests. + 2003-11-01 Dirk Herrmann * tests/syntax.test (exception:missing/extra-expr-misc): Removed. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 9691f2bfc..3a0b8c982 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -28,6 +28,8 @@ (cons 'syntax-error "Missing or extra expression")) (define exception:missing-expr (cons 'syntax-error "Missing expression")) +(define exception:missing-body-expr + (cons 'syntax-error "Missing body expression")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination @@ -588,13 +590,15 @@ (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) -(with-test-prefix "define" +(with-test-prefix "top-level define" (with-test-prefix "currying" (pass-if "(define ((foo)) #f)" - (define ((foo)) #t) - ((foo)))) + (eval '(begin + (define ((foo)) #t) + ((foo))) + (interaction-environment)))) (with-test-prefix "missing or extra expressions" @@ -603,6 +607,47 @@ (eval '(define) (interaction-environment))))) +(with-test-prefix "internal define" + + (pass-if "internal defines become letrec" + (eval '(let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (define (b x) (if (= x 0) 'b (c (- x 1)))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5)))) + (interaction-environment))) + + (expect-fail "internal defines with begin" + (false-if-exception + (eval '(let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (begin + (define (b x) (if (= x 0) 'b (c (- x 1))))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5)))) + (interaction-environment)))) + + (expect-fail "internal defines with empty begin" + (false-if-exception + (eval '(let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (begin) + (define (b x) (if (= x 0) 'b (c (- x 1)))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5)))) + (interaction-environment)))) + + (pass-if-exception "missing body expression" + exception:missing-body-expr + (eval '(let () (define x #t)) + (interaction-environment)))) + (with-test-prefix "set!" (with-test-prefix "missing or extra expressions"