* libguile/eval.c (scm_m_cont, scm_m_at_call_with_values,

scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax
	errors.  Avoid unnecessary consing when creating the memoized
	code.

	(scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS
	standard case.  Make sure line and file information are copied to
	every created expression.

	* test-suite/tests/syntax.test (exception:bad-var): Removed.

	Adapted tests for 'set!' to the new way of error reporting.

libguile/ChangeLog

@@ -1,3 +1,14 @@
+2003-10-18  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* eval.c (scm_m_cont, scm_m_at_call_with_values,
+	scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax
+	errors.  Avoid unnecessary consing when creating the memoized
+	code.
+
+	(scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS
+	standard case.  Make sure line and file information are copied to
+	every created expression.
+
 2003-10-18  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use
@@ -55,7 +66,7 @@
 	specific about the kind of error that was detected.  Prepare for
 	easier integration of changes for separated memoization.
 
-2003-10-11  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+2003-10-12  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* eval.c (s_duplicate_binding): New static identifier.
 
@@ -77,7 +88,7 @@
 
 	(SCM_CEVAL): Simplified handling of SCM_IM_IF forms.
 
-2003-10-11  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+2003-10-12  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New
 	static identifiers.
@@ -88,7 +99,7 @@
 	code, this way also making sure that file name, line number
 	information etc. remain available.
 
-2003-10-11  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+2003-10-12  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* eval.c (memoize_as_thunk_prototype): New static function.
 

libguile/eval.c

@@ -1579,13 +1579,15 @@ scm_m_atbind (SCM expr, SCM env)
 SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
 
-
 SCM 
-scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
+scm_m_cont (SCM expr, SCM env SCM_UNUSED)
 {
-  SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
+  const SCM cdr_expr = SCM_CDR (expr);
-	      s_expression, s_atcall_cc);
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
-  return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+  SCM_SETCAR (expr, SCM_IM_CONT);
+  return expr;
 }
 
 
@@ -1593,11 +1595,14 @@ SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_
 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
 
 SCM
-scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
+scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
 {
-  SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
+  const SCM cdr_expr = SCM_CDR (expr);
-	      s_expression, s_at_call_with_values);
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
-  return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+  SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
+  return expr;
 }
 
 
@@ -1622,17 +1627,34 @@ SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
 SCM_SYMBOL (scm_sym_setter, "setter");
 
 SCM 
-scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)
+scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED)
 {
-  SCM x = SCM_CDR (xorig);
+  SCM target;
-  SCM_ASSYNT (2 == scm_ilength (x), s_expression, s_set_x);
+
-  if (SCM_SYMBOLP (SCM_CAR (x)))
+  const SCM cdr_expr = SCM_CDR (expr);
-    return scm_cons (SCM_IM_SET_X, x);
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
-  else if (SCM_CONSP (SCM_CAR (x)))
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
-    return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),
+
-		     scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));
+  target = SCM_CAR (cdr_expr);
+  if (!SCM_CONSP (target))
+    {
+      /* R5RS usage */
+      return scm_m_set_x (expr, env);
+    }
   else
-    scm_misc_error (s_set_x, s_variable, SCM_EOL);
+    {
+      /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
+
+      const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
+      const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, setter_proc_tail);
+
+      const SCM cddr_expr = SCM_CDR (cdr_expr);
+      const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), cddr_expr));
+
+      SCM_SETCAR (expr, setter_proc);
+      SCM_SETCDR (expr, setter_args);
+      return expr;
+    }
 }
 
 

test-suite/ChangeLog

@@ -1,3 +1,9 @@
+2003-10-18  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* tests/syntax.test (exception:bad-var): Removed.
+
+	Adapted tests for 'set!' to the new way of error reporting.
+
 2003-10-18  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* tests/dynamic-scope.test (exception:missing-expr): Introduced

test-suite/tests/syntax.test

@@ -59,9 +59,6 @@
 (define exception:bad-cond-clause
   (cons 'syntax-error "Bad cond clause"))
 
-(define exception:bad-var
-  (cons 'misc-error "^bad variable"))
-
 
 (with-test-prefix "expressions"
 
@@ -611,44 +608,44 @@
   (with-test-prefix "missing or extra expressions"
 
     (pass-if-exception "(set!)"
-      exception:missing/extra-expr-misc
+      exception:missing/extra-expr
       (eval '(set!)
 	    (interaction-environment)))
 
     (pass-if-exception "(set! 1)"
-      exception:missing/extra-expr-misc
+      exception:missing/extra-expr
       (eval '(set! 1)
 	    (interaction-environment)))
 
     (pass-if-exception "(set! 1 2 3)"
-      exception:missing/extra-expr-misc
+      exception:missing/extra-expr
       (eval '(set! 1 2 3)
 	    (interaction-environment))))
 
   (with-test-prefix "bad variable"
 
     (pass-if-exception "(set! \"\" #t)"
-      exception:bad-var
+      exception:bad-variable
       (eval '(set! "" #t)
 	    (interaction-environment)))
 
     (pass-if-exception "(set! 1 #t)"
-      exception:bad-var
+      exception:bad-variable
       (eval '(set! 1 #t)
 	    (interaction-environment)))
 
     (pass-if-exception "(set! #t #f)"
-      exception:bad-var
+      exception:bad-variable
       (eval '(set! #t #f)
 	    (interaction-environment)))
 
     (pass-if-exception "(set! #f #t)"
-      exception:bad-var
+      exception:bad-variable
       (eval '(set! #f #t)
 	    (interaction-environment)))
 
     (pass-if-exception "(set! #\space #f)"
-      exception:bad-var
+      exception:bad-variable
       (eval '(set! #\space #f)
 	    (interaction-environment)))))