mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 23:10:21 +02:00
Code Activity

* libguile/tags.h (SCM_IM_ELSE, SCM_IM_ARROW): New memoizer codes.

Browse source 
* libguile/print.c (scm_isymnames): Add names for the new memoizer
        codes.

	* libguile/eval.c (s_missing_clauses, s_bad_case_clause,
	s_extra_case_clause, s_bad_case_labels, s_duplicate_case_label,
	literal_p): New static identifiers.

	(scm_m_case): Use ASSERT_SYNTAX to signal syntax errors.  Be more
	specific about the kind of error that was detected.  Check for
	duplicate case labels.  Handle bound 'else.  Avoid unnecessary
	consing when creating the memoized code.

	(scm_m_case, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize
	the syntactic keyword 'else.

	* test-suite/tests/syntax.test (exception:bad-expression,
	exception:missing-clauses, exception:bad-case-clause,
	exception:extra-case-clause, exception:bad-case-labels): New.

	Added some tests and adapted tests for 'case' to the new way of
	error reporting.
This commit is contained in:
Dirk Herrmann 2003-10-11 00:57:25 +00:00
parent e6729603c0
commit 2a6f7afe04
6 changed files with 174 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

18
libguile/ChangeLog
View file

@ -1,3 +1,21 @@
2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tags.h (SCM_IM_ELSE, SCM_IM_ARROW): New memoizer codes.
* print.c (scm_isymnames): Add names for the new memoizer codes.
* eval.c (s_missing_clauses, s_bad_case_clause,
s_extra_case_clause, s_bad_case_labels, s_duplicate_case_label,
literal_p): New static identifiers.
(scm_m_case): Use ASSERT_SYNTAX to signal syntax errors. Be more
specific about the kind of error that was detected. Check for
duplicate case labels. Handle bound 'else. Avoid unnecessary
consing when creating the memoized code.
(scm_m_case, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize
the syntactic keyword 'else.
2003-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (s_bad_expression, syntax_error_key, syntax_error,

122
libguile/eval.c
View file

@ -100,6 +100,35 @@ char *alloca ();
* expression is expected, a 'Bad expression' error is signalled. */
static const char s_bad_expression[] = "Bad expression";
/* Case or cond expressions must have at least one clause. If a case or cond
* expression without any clauses is detected, a 'Missing clauses' error is
* signalled. */
static const char s_missing_clauses[] = "Missing clauses";
/* If a case clause is detected that is not in the format
* (<label(s)> <expression1> <expression2> ...)
* a 'Bad case clause' error is signalled. */
static const char s_bad_case_clause[] = "Bad case clause";
/* If there is an 'else' clause in a case statement, it must be the last
* clause. If after the 'else' case clause further clauses are detected, an
* 'Extra case clause' error is signalled. */
static const char s_extra_case_clause[] = "Extra case clause";
/* If a case clause is detected where the <label(s)> element is neither a
* proper list nor (in case of the last clause) the syntactic keyword 'else',
* a 'Bad case labels' error is signalled. Note: If you encounter this error
* for an else-clause which seems to be syntactically correct, check if 'else'
* is really a syntactic keyword in that context. If 'else' is bound in the
* local or global environment, it is not considered a syntactic keyword, but
* will be treated as any other variable. */
static const char s_bad_case_labels[] = "Bad case labels";
/* In a case statement all labels have to be distinct. If in a case statement
* a label occurs more than once, a 'Duplicate case label' error is
* signalled. */
static const char s_duplicate_case_label[] = "Duplicate case label";
/* Signal a syntax error. We distinguish between the form that caused the
* error and the enclosing expression. The error message will print out as
@ -529,6 +558,22 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
return loc;
}
/* Return true if the symbol is - from the point of view of a macro
* transformer - a literal in the sense specified in chapter "pattern
* language" of R5RS. In the code below, however, we don't match the
* definition of R5RS exactly: It returns true if the identifier has no
* binding or if it is a syntactic keyword. */
static int
literal_p (const SCM symbol, const SCM env)
{
const SCM x = scm_cons (symbol, SCM_UNDEFINED);
const SCM value = *scm_lookupcar (x, env, 0);
if (SCM_UNBNDP (value) || SCM_MACROP (value))
return 1;
else
return 0;
}
#define unmemocar scm_unmemocar
SCM_SYMBOL (sym_three_question_marks, "???");
@ -653,10 +698,14 @@ SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
SCM
scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, s_expression, s_begin);
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
const SCM cdr_expr = SCM_CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
SCM_SETCAR (expr, SCM_IM_BEGIN);
return expr;
}
@ -664,23 +713,63 @@ SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
SCM
scm_m_case (SCM xorig, SCM env SCM_UNUSED)
scm_m_case (SCM expr, SCM env)
{
SCM clauses;
SCM cdrx = SCM_CDR (xorig);
SCM_ASSYNT (scm_ilength (cdrx) >= 2, s_clauses, s_case);
clauses = SCM_CDR (cdrx);
SCM all_labels = SCM_EOL;
/* Check, whether 'else is a literal, i. e. not bound to a value. */
const int else_literal_p = literal_p (scm_sym_else, env);
const SCM cdr_expr = SCM_CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
clauses = SCM_CDR (cdr_expr);
while (!SCM_NULLP (clauses))
{
SCM clause = SCM_CAR (clauses);
SCM_ASSYNT (scm_ilength (clause) >= 2, s_clauses, s_case);
SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0
|| (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))
&& SCM_NULLP (SCM_CDR (clauses))),
s_clauses, s_case);
SCM labels;
const SCM clause = SCM_CAR (clauses);
ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
s_bad_case_clause, clause, expr);
labels = SCM_CAR (clause);
if (SCM_CONSP (labels))
{
ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
s_bad_case_labels, labels, expr);
all_labels = scm_append_x (scm_list_2 (labels, all_labels));
}
else
{
ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p,
s_bad_case_labels, labels, expr);
ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)),
s_extra_case_clause, SCM_CDR (clauses), expr);
}
/* build the new clause */
if (SCM_EQ_P (labels, scm_sym_else))
SCM_SETCAR (clause, SCM_IM_ELSE);
clauses = SCM_CDR (clauses);
}
return scm_cons (SCM_IM_CASE, cdrx);
/* Check whether all case labels are distinct. */
for (; !SCM_NULLP (all_labels); all_labels = SCM_CDR (all_labels))
{
const SCM label = SCM_CAR (all_labels);
SCM label_idx = SCM_CDR (all_labels);
for (; !SCM_NULLP (label_idx); label_idx = SCM_CDR (label_idx))
{
ASSERT_SYNTAX_2 (!SCM_EQ_P (SCM_CAR (label_idx), label),
s_duplicate_case_label, label, expr);
}
}
SCM_SETCAR (expr, SCM_IM_CASE);
return expr;
}
@ -1762,6 +1851,9 @@ unmemocopy (SCM x, SCM env)
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
goto loop;
case (SCM_ISYMNUM (SCM_IM_ELSE)):
ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED);
goto loop;
default:
/* appease the Sun compiler god: */ ;
}
@ -2297,7 +2389,7 @@ dispatch:
{
SCM clause = SCM_CAR (x);
SCM labels = SCM_CAR (clause);
if (SCM_EQ_P (labels, scm_sym_else))
if (SCM_EQ_P (labels, SCM_IM_ELSE))
{
x = SCM_CDR (clause);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);

2
libguile/print.c
View file

@ -98,6 +98,8 @@ char *scm_isymnames[] =
"#@delay",
"#@future",
"#@call-with-values",
"#@else",
"#@arrow",
/* Multi-language support */
"#@nil-cond",

6
libguile/tags.h
View file

@ -584,11 +584,13 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */
#define SCM_IM_DELAY SCM_MAKISYM (19)
#define SCM_IM_FUTURE SCM_MAKISYM (20)
#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21)
#define SCM_IM_ELSE SCM_MAKISYM (22)
#define SCM_IM_ARROW SCM_MAKISYM (23)
/* Multi-language support */
#define SCM_IM_NIL_COND SCM_MAKISYM (22)
#define SCM_IM_BIND SCM_MAKISYM (23)
#define SCM_IM_NIL_COND SCM_MAKISYM (24)
#define SCM_IM_BIND SCM_MAKISYM (25)

9
test-suite/ChangeLog
View file

@ -1,3 +1,12 @@
2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tests/syntax.test (exception:bad-expression,
exception:missing-clauses, exception:bad-case-clause,
exception:extra-case-clause, exception:bad-case-labels): New.
Added some tests and adapted tests for 'case' to the new way of
error reporting.
2003-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* lib.scm (run-test-exception): Handle syntax errors.

46
test-suite/tests/syntax.test
View file

@ -20,6 +20,9 @@
(define-module (test-suite test-syntax)
:use-module (test-suite lib))
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
(define exception:bad-bindings
(cons 'misc-error "^bad bindings"))
(define exception:duplicate-bindings
@ -30,10 +33,18 @@
(cons 'misc-error "^bad formals"))
(define exception:duplicate-formals
(cons 'misc-error "^duplicate formals"))
(define exception:missing-clauses
(cons 'syntax-error "Missing clauses"))
(define exception:bad-var
(cons 'misc-error "^bad variable"))
(define exception:bad/missing-clauses
(cons 'misc-error "^bad or missing clauses"))
(define exception:bad-case-clause
(cons 'syntax-error "Bad case clause"))
(define exception:extra-case-clause
(cons 'syntax-error "Extra case clause"))
(define exception:bad-case-labels
(cons 'syntax-error "Bad case labels"))
(define exception:missing/extra-expr
(cons 'misc-error "^missing or extra expression"))
@ -472,6 +483,10 @@
(with-test-prefix "cond is hygienic"
(expect-fail "bound 'else is handled correctly"
(false-if-exception
(eq? (let ((else 'ok)) (cond (else))) 'ok)))
(expect-fail "bound '=> is handled correctly"
(false-if-exception
(eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok))))
@ -494,45 +509,52 @@
(with-test-prefix "case"
(with-test-prefix "case is hygienic"
(pass-if-exception "bound 'else is handled correctly"
exception:bad-case-labels
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
exception:bad/missing-clauses
exception:missing-clauses
(eval '(case)
(interaction-environment)))
(pass-if-exception "(case . \"foo\")"
exception:bad/missing-clauses
exception:bad-expression
(eval '(case . "foo")
(interaction-environment)))
(pass-if-exception "(case 1)"
exception:bad/missing-clauses
exception:missing-clauses
(eval '(case 1)
(interaction-environment)))
(pass-if-exception "(case 1 . \"foo\")"
exception:bad/missing-clauses
exception:bad-expression
(eval '(case 1 . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 \"foo\")"
exception:bad/missing-clauses
exception:bad-case-clause
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ())"
exception:bad/missing-clauses
exception:bad-case-clause
(eval '(case 1 ())
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\"))"
exception:bad/missing-clauses
exception:bad-case-clause
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
exception:bad/missing-clauses
exception:bad-case-labels
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
@ -542,22 +564,22 @@
;; (case 1 (() "bar")))
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
exception:bad/missing-clauses
exception:bad-expression
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
exception:bad/missing-clauses
exception:bad-case-clause
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) . \"foo\")"
exception:bad/missing-clauses
exception:bad-expression
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) ((1) #t))"
exception:bad/missing-clauses
exception:extra-case-clause
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))