diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 862c3a656..90dec9bb1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2003-10-11 Dirk Herrmann + + * 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 * eval.c (s_bad_expression, syntax_error_key, syntax_error, diff --git a/libguile/eval.c b/libguile/eval.c index e91e2fbcc..25f435468 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -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 + * ( ...) + * 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 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); diff --git a/libguile/print.c b/libguile/print.c index 50b969e24..4ff0aeb3e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -98,6 +98,8 @@ char *scm_isymnames[] = "#@delay", "#@future", "#@call-with-values", + "#@else", + "#@arrow", /* Multi-language support */ "#@nil-cond", diff --git a/libguile/tags.h b/libguile/tags.h index d001a9d83..f58bf5853 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -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) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 11364ea30..d5f6646d0 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,12 @@ +2003-10-11 Dirk Herrmann + + * 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 * lib.scm (run-test-exception): Handle syntax errors. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 3261ea1f6..20e9a44a5 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -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)))))