From e6729603c0f9a1511aaf32001e808b5f97009176 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 10 Oct 2003 21:49:27 +0000 Subject: [PATCH] * libguile/eval.c (s_bad_expression, syntax_error_key, syntax_error, ASSERT_SYNTAX, ASSERT_SYNTAX_2): New static identifiers. (scm_m_and): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. * test-suite/lib.scm (run-test-exception): Handle syntax errors. --- libguile/ChangeLog | 8 +++ libguile/eval.c | 122 ++++++++++++++++++++++++++++++++++++++++--- test-suite/ChangeLog | 4 ++ test-suite/lib.scm | 7 +++ 4 files changed, 135 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ca42a037b..862c3a656 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2003-10-10 Dirk Herrmann + + * eval.c (s_bad_expression, syntax_error_key, syntax_error, + ASSERT_SYNTAX, ASSERT_SYNTAX_2): New static identifiers. + + (scm_m_and): Use ASSERT_SYNTAX to signal syntax errors. Avoid + unnecessary consing when creating the memoized code. + 2003-10-09 Kevin Ryde * numbers.c (scm_inexact_to_exact): Don't depend on what double->long diff --git a/libguile/eval.c b/libguile/eval.c index d52c84360..e91e2fbcc 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -60,6 +60,7 @@ char *alloca (); #include "libguile/eq.h" #include "libguile/continuations.h" #include "libguile/futures.h" +#include "libguile/strings.h" #include "libguile/throw.h" #include "libguile/smob.h" #include "libguile/macros.h" @@ -85,6 +86,106 @@ char *alloca (); +/* {Syntax Errors} + * + * This section defines the message strings for the syntax errors that can be + * detected during memoization and the functions and macros that shall be + * called by the memoizer code to signal syntax errors. */ + + +/* Syntax errors that can be detected during memoization: */ + +/* Circular or improper lists do not form valid scheme expressions. If a + * circular list or an improper list is detected in a place where a scheme + * expression is expected, a 'Bad expression' error is signalled. */ +static const char s_bad_expression[] = "Bad expression"; + + +/* Signal a syntax error. We distinguish between the form that caused the + * error and the enclosing expression. The error message will print out as + * shown in the following pattern. The file name and line number are only + * given when they can be determined from the erroneous form or from the + * enclosing expression. + * + * : In procedure memoization: + * : In file , line : in . */ + +SCM_SYMBOL (syntax_error_key, "syntax-error"); + +/* The prototype is needed to indicate that the function does not return. */ +static void +syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN; + +static void +syntax_error (const char* const msg, const SCM form, const SCM expr) +{ + const SCM msg_string = scm_makfrom0str (msg); + SCM filename = SCM_BOOL_F; + SCM linenr = SCM_BOOL_F; + const char *format; + SCM args; + + if (SCM_CONSP (form)) + { + filename = scm_source_property (form, scm_sym_filename); + linenr = scm_source_property (form, scm_sym_line); + } + + if (SCM_FALSEP (filename) && SCM_FALSEP (linenr) && SCM_CONSP (expr)) + { + filename = scm_source_property (expr, scm_sym_filename); + linenr = scm_source_property (expr, scm_sym_line); + } + + if (!SCM_UNBNDP (expr)) + { + if (!SCM_FALSEP (filename)) + { + format = "In file ~S, line ~S: ~A ~S in expression ~S."; + args = scm_list_5 (filename, linenr, msg_string, form, expr); + } + else if (!SCM_FALSEP (linenr)) + { + format = "In line ~S: ~A ~S in expression ~S."; + args = scm_list_4 (linenr, msg_string, form, expr); + } + else + { + format = "~A ~S in expression ~S."; + args = scm_list_3 (msg_string, form, expr); + } + } + else + { + if (!SCM_FALSEP (filename)) + { + format = "In file ~S, line ~S: ~A ~S."; + args = scm_list_4 (filename, linenr, msg_string, form); + } + else if (!SCM_FALSEP (linenr)) + { + format = "In line ~S: ~A ~S."; + args = scm_list_3 (linenr, msg_string, form); + } + else + { + format = "~A ~S."; + args = scm_list_2 (msg_string, form); + } + } + + scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); +} + + +/* Shortcut macros to simplify syntax error handling. */ +#define ASSERT_SYNTAX(cond, message, form) \ + { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); } +#define ASSERT_SYNTAX_2(cond, message, form, expr) \ + { if (!(cond)) syntax_error (message, form, expr); } + + + /* {Ilocs} * * Ilocs are memoized references to variables in local environment frames. @@ -528,14 +629,23 @@ SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and); SCM_GLOBAL_SYMBOL (scm_sym_and, s_and); SCM -scm_m_and (SCM xorig, SCM env SCM_UNUSED) +scm_m_and (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, s_test, s_and); - if (len >= 1) - return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + + if (length == 0) + { + /* Special case: (and) is replaced by #t. */ + return SCM_BOOL_T; + } else - return SCM_BOOL_T; + { + SCM_SETCAR (expr, SCM_IM_AND); + return expr; + } } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5a3ff964c..11364ea30 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-10-10 Dirk Herrmann + + * lib.scm (run-test-exception): Handle syntax errors. + 2003-10-10 Marius Vollmer * tests/numbers.test (inexact->exact): Use corrent argument order diff --git a/test-suite/lib.scm b/test-suite/lib.scm index bf27d9621..7248b3e96 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -323,6 +323,13 @@ (string-match (cdr exception) (apply simple-format #f message (car rest)))) #t) + ;; handle syntax errors which use `syntax-error' for key and don't + ;; yet format the message and args (we have to do it here). + ((and (eq? 'syntax-error (car exception)) + (list? rest) + (string-match (cdr exception) + (apply simple-format #f message (car rest)))) + #t) ;; unhandled; throw again (else (apply throw key proc message rest))))))))