summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2003-11-08 08:11:14 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2003-11-08 08:11:14 +0000
commitced8edb0f9545e7e37ec62cf7ab6c0c1c66fe1db (patch)
tree4aca6e37b765f5e260f08e5b4ff1646bd65937f5
parenta5fda890f5b9eb07240355924ccaf78ba842bcaf (diff)
downloadguile-ced8edb0f9545e7e37ec62cf7ab6c0c1c66fe1db.tar.gz
* 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.
-rw-r--r--libguile/ChangeLog10
-rw-r--r--libguile/eval.c13
-rw-r--r--test-suite/ChangeLog7
-rw-r--r--test-suite/tests/syntax.test51
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 <D.Herrmann@tu-bs.de>
+
+ * 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 <D.Herrmann@tu-bs.de>
* 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 <D.Herrmann@tu-bs.de>
+
+ * 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 <D.Herrmann@tu-bs.de>
* 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"