* Eliminate some calls to scm_wta.

libguile/ChangeLog

@@ -1,3 +1,16 @@
+2001-03-04  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* continuations.c (continuation_apply), eval.c (scm_m_lambda,
+	scm_m_letstar, scm_m_letrec1, scm_m_let, SCM_APPLY), eval.h
+	(SCM_EVALIM2), evalext.c (scm_m_generalized_set_x), gc.c
+	(get_bvec, MARK), goops.c (scm_primitive_generic_generic),
+	options.c (scm_options), ports.c (scm_remove_from_port_table),
+	ramap.c (scm_ramapc), read.c (skip_scsh_block_comment, scm_lreadr,
+	scm_lreadparen, scm_lreadrecparen), script.c (script_get_octal,
+	script_get_backslash, script_read_arg), unif.c (scm_cvref):  Don't
+	call function scm_wta, call scm_misc_error or scm_wrong_type_arg
+	instead.
+
 2001-03-04  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>
 
 	* goops.c (scm_sys_pre_expand_closure_x): New procedure.

libguile/continuations.c

@@ -59,6 +59,7 @@
 #include "libguile/debug.h"
 #endif
 
+#include "libguile/validate.h"
 #include "libguile/continuations.h"
 
 
@@ -219,8 +220,10 @@ scm_dynthrow (SCM cont, SCM val)
   copy_stack_and_call (continuation, val, dst);
 }
 
+
+static SCM
+continuation_apply (SCM cont, SCM args)
 #define FUNC_NAME "continuation_apply"
-static SCM continuation_apply (SCM cont, SCM args)
 {
   scm_contregs *continuation = SCM_CONTREGS (cont);
   scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
@@ -229,7 +232,8 @@ static SCM continuation_apply (SCM cont, SCM args)
       /* this base comparison isn't needed */
       || continuation->base != rootcont->base)
     {
-      scm_wta (cont, "continuation from wrong top level", FUNC_NAME);
+      SCM_MISC_ERROR ("continuation from wrong top level: ~S", 
+		      SCM_LIST1 (cont));
     }
   
   scm_dowinds (continuation->dynenv,
@@ -241,6 +245,7 @@ static SCM continuation_apply (SCM cont, SCM args)
 }
 #undef FUNC_NAME
 
+
 void
 scm_init_continuations ()
 {

libguile/eval.c

@@ -681,13 +681,13 @@ scm_m_lambda (SCM xorig, SCM env)
       if (!SCM_SYMBOLP (SCM_CAR (proc)))
 	goto badforms;
       else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc)))
-	scm_wta (xorig, scm_s_duplicate_formals, s_lambda);
+	scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
       proc = SCM_CDR (proc);
     }
   if (SCM_NNULLP (proc))
     {
     badforms:
-      scm_wta (xorig, scm_s_formals, s_lambda);
+      scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
     }
 
  memlambda:
@@ -713,7 +713,7 @@ scm_m_letstar (SCM xorig, SCM env)
       SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar);
       SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar);
       if (scm_c_improper_memq (SCM_CAR (arg1), vars))
-	scm_wta (xorig, scm_s_duplicate_bindings, s_letstar);
+	scm_misc_error (s_letstar, scm_s_duplicate_bindings, SCM_EOL);
       *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
       varloc = SCM_CDRLOC (SCM_CDR (*varloc));
       proc = SCM_CDR (proc);
@@ -920,7 +920,7 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
       SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, what);
       SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what);
       if (scm_c_improper_memq (SCM_CAR (arg1), vars))
-	scm_wta (xorig, scm_s_duplicate_bindings, what);
+	scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
       vars = scm_cons (SCM_CAR (arg1), vars);
       *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
       initloc = SCM_CDRLOC (*initloc);
@@ -982,7 +982,7 @@ scm_m_let (SCM xorig, SCM env)
     }
 
   if (!SCM_SYMBOLP (proc))
-    scm_wta (xorig, scm_s_bindings, s_let);	/* bad let */
+    scm_misc_error (s_let, scm_s_bindings, SCM_EOL);	/* bad let */
   name = proc;			/* named let, build equiv letrec */
   x = SCM_CDR (x);
   SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
@@ -3559,7 +3559,7 @@ tail:
       scm_wrong_num_args (proc);
     default:
     badproc:
-      scm_wta (proc, (char *) SCM_ARG1, "apply");
+      scm_wrong_type_arg ("apply", SCM_ARG1, proc);
       RETURN (arg1);
     }
 #ifdef DEVAL

libguile/eval.h

@@ -98,7 +98,7 @@ extern SCM scm_eval_options_interface (SCM setting);
  * For an explanation of symbols containing "EVAL", see beginning of eval.c.
  */
 #define SCM_EVALIM2(x) (((x) == SCM_EOL) \
-			? scm_wta ((x), scm_s_expression, NULL) \
+			? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \
 			: (x))
 #ifdef MEMOIZE_LOCALS
 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \

libguile/evalext.c

@@ -65,7 +65,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env)
   else if (SCM_CONSP (SCM_CAR (x)))
     return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)),
 		     scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x))));
-  return scm_wta (xorig, scm_s_variable, scm_s_set_x);
+  else
+    scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL);
 }
 
 SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0,

libguile/gc.c

@@ -408,6 +408,7 @@ static scm_mark_space_t *mark_space_head;
 
 static scm_c_bvec_limb_t *
 get_bvec ()
+#define FUNC_NAME "get_bvec"
 {
   scm_c_bvec_limb_t *res;
 
@@ -415,7 +416,7 @@ get_bvec ()
     {
       SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t)));
       if (!current_mark_space)
-        scm_wta (SCM_UNDEFINED, "could not grow", "heap");
+        SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
 
       current_mark_space->bvec_space = NULL;
       current_mark_space->next = NULL;
@@ -431,7 +432,7 @@ get_bvec ()
       SCM_SYSCALL (current_mark_space->bvec_space =
                    (scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1));
       if (!(current_mark_space->bvec_space))
-        scm_wta (SCM_UNDEFINED, "could not grow", "heap");
+        SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
 
       current_mark_space_offset = 0;
 
@@ -450,6 +451,8 @@ get_bvec ()
 
   return res;
 }
+#undef FUNC_NAME
+
 
 static void
 clear_mark_space ()
@@ -1143,7 +1146,7 @@ gc_mark_loop_first_time:
 #if (defined (GUILE_DEBUG_FREELIST))
 
   if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr)))
-    scm_wta (ptr, "rogue pointer in heap", NULL);
+    SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
 
 #endif
 

libguile/goops.c

@@ -1644,7 +1644,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
       if (gf)
 	return gf;
     }
-  return scm_wta (subr, (char *) SCM_ARG1, FUNC_NAME);
+  SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
 }
 #undef FUNC_NAME
 

libguile/options.c

@@ -190,7 +190,8 @@ scm_options (SCM arg, scm_option options[], int n, const char *s)
 		}
 #ifndef SCM_RECKLESS
 	  scm_must_free ((char *) flags);
-	  scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s);
+	  scm_misc_error (s, "Unknown mode flag: ~S", 
+			  SCM_LIST1 (SCM_CAR (new_mode)));
 #endif
 	cont:
 	  new_mode = SCM_CDR (new_mode);

libguile/ports.c

@@ -468,12 +468,13 @@ scm_add_to_port_table (SCM port)
 
 void
 scm_remove_from_port_table (SCM port)
+#define FUNC_NAME "scm_remove_from_port_table"
 {
   scm_port *p = SCM_PTAB_ENTRY (port);
   int i = p->entry;
 
   if (i >= scm_port_table_size)
-    scm_wta (port, "Port not in table", "scm_remove_from_port_table");
+    SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port));
   if (p->putback_buf)
     free (p->putback_buf);
   free (p);
@@ -487,6 +488,8 @@ scm_remove_from_port_table (SCM port)
   SCM_SETPTAB_ENTRY (port, 0);
   scm_port_table_size--;
 }
+#undef FUNC_NAME
+
 
 #ifdef GUILE_DEBUG
 /* Functions for debugging.  */

libguile/ramap.c

@@ -329,7 +329,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
     {
     default:
     case 0:
-      scm_wta (ra0, "array shape mismatch", what);
+      scm_misc_error (what, "array shape mismatch: ~S", ra0);
     case 2:
     case 3:
     case 4:			/* Try unrolling arrays */

libguile/read.c

@@ -255,6 +255,7 @@ recsexpr (SCM obj,int line,int column,SCM filename)
 
 static void
 skip_scsh_block_comment (SCM port)
+#define FUNC_NAME "skip_scsh_block_comment"
 {
   /* Is this portable?  Dear God, spare me from the non-eight-bit
      characters.  But is it tasteful?  */
@@ -265,8 +266,7 @@ skip_scsh_block_comment (SCM port)
       int c = scm_getc (port);
 
       if (c == EOF)
-	scm_wta (SCM_UNDEFINED,
+	SCM_MISC_ERROR ("unterminated `#! ... !#' comment", SCM_EOL);
-		 "unterminated `#! ... !#' comment", "read");
       history = ((history << 8) | (c & 0xff)) & 0xffffffff;
 
       /* Were the last four characters read "\n!#\n"?  */
@@ -274,6 +274,8 @@ skip_scsh_block_comment (SCM port)
 	return;
     }
 }
+#undef FUNC_NAME
+
 
 static SCM scm_get_hash_procedure(int c);
 
@@ -281,6 +283,7 @@ static char s_list[]="list";
 
 SCM 
 scm_lreadr (SCM *tok_buf,SCM port,SCM *copy)
+#define FUNC_NAME "scm_lreadr"
 {
   int c;
   scm_sizet j;
@@ -299,7 +302,7 @@ tryagain_no_flush_ws:
 	     ? scm_lreadrecparen (tok_buf, port, s_list, copy)
 	     : scm_lreadparen (tok_buf, port, s_list, copy);
     case ')':
-      scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
+      SCM_MISC_ERROR ("unexpected \")\"", SCM_EOL);
       goto tryagain;
     
     case '\'':
@@ -402,7 +405,7 @@ tryagain_no_flush_ws:
 	    if (scm_charnames[c]
 		&& (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf))))
 	      return SCM_MAKE_CHAR (scm_charnums[c]);
-	  scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_STRING_CHARS (*tok_buf));
+	  SCM_MISC_ERROR ("unknown # object", SCM_EOL);
 
 	  /* #:SYMBOL is a syntax for keywords supported in all contexts.  */
 	case ':':
@@ -504,7 +507,7 @@ tryagain_no_flush_ws:
 	      c = SCM_STRING_CHARS (*tok_buf)[1];
 	      goto callshrp;
 	    }
-	  scm_wta (SCM_UNDEFINED, "unknown # object", SCM_STRING_CHARS (*tok_buf));
+	  SCM_MISC_ERROR ("unknown # object", SCM_EOL);
 	}
       goto tok;
 
@@ -524,6 +527,8 @@ tryagain_no_flush_ws:
       return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j);
     }
 }
+#undef FUNC_NAME
+
 
 #ifdef _UNICOS
 _Pragma ("noopt");		/* # pragma _CRI noopt */
@@ -617,6 +622,7 @@ _Pragma ("opt");		/* # pragma _CRI opt */
 
 SCM 
 scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
+#define FUNC_NAME "scm_lreadparen"
 {
   SCM tmp;
   SCM tl;
@@ -632,7 +638,7 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
       ans = scm_lreadr (tok_buf, port, copy);
     closeit:
       if (')' != (c = scm_flush_ws (port, name)))
-	scm_wta (SCM_UNDEFINED, "missing close paren", "");
+	SCM_MISC_ERROR ("missing close paren", SCM_EOL);
       return ans;
     }
   ans = tl = scm_cons (tmp, SCM_EOL);
@@ -649,10 +655,12 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
     }
   return ans;
 }
+#undef FUNC_NAME
 
 
 SCM 
 scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
+#define FUNC_NAME "scm_lreadrecparen"
 {
   register int c;
   register SCM tmp;
@@ -670,7 +678,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
     {
       ans = scm_lreadr (tok_buf, port, copy);
       if (')' != (c = scm_flush_ws (port, name)))
-	scm_wta (SCM_UNDEFINED, "missing close paren", "");
+	SCM_MISC_ERROR ("missing close paren", SCM_EOL);
       return ans;
     }
   /* Build the head of the list structure. */
@@ -694,7 +702,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
 				       : tmp,
 				       SCM_EOL));
 	  if (')' != (c = scm_flush_ws (port, name)))
-	    scm_wta (SCM_UNDEFINED, "missing close paren", "");
+	    SCM_MISC_ERROR ("missing close paren", SCM_EOL);
 	  goto exit;
 	}
 
@@ -721,6 +729,7 @@ exit:
 				       SCM_EOL));
   return ans;
 }
+#undef FUNC_NAME
 
 
 

libguile/script.c

@@ -51,6 +51,7 @@
 #include "libguile/load.h"
 #include "libguile/version.h"
 
+#include "libguile/validate.h"
 #include "libguile/script.h"
 
 #ifdef HAVE_STRING_H
@@ -168,6 +169,7 @@ scm_find_executable (const char *name)
 /* Read a \nnn-style escape.  We've just read the backslash.  */
 static int
 script_get_octal (FILE *f)
+#define FUNC_NAME "script_get_octal"
 {
   int i;
   int value = 0;
@@ -178,16 +180,17 @@ script_get_octal (FILE *f)
       if ('0' <= c && c <= '7')
 	value = (value * 8) + (c - '0');
       else
-	scm_wta (SCM_UNDEFINED,
+	SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
-		 "malformed script: bad octal backslash escape",
+			SCM_EOL);
-		 "script argument parser");
     }
   return value;
 }
+#undef FUNC_NAME
 
 
 static int
 script_get_backslash (FILE *f)
+#define FUNC_NAME "script_get_backslash"
 {
   int c = getc (f);
 
@@ -211,24 +214,22 @@ script_get_backslash (FILE *f)
     case '4': case '5': case '6': case '7':
       ungetc (c, f);
       return script_get_octal (f);
-	    
+
     case EOF:
-      scm_wta (SCM_UNDEFINED,
+      SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
-	       "malformed script: backslash followed by EOF",
-	       "script argument parser");
       return 0; /* not reached? */
 
     default:
-      scm_wta (SCM_UNDEFINED,
+      SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
-	       "malformed script: bad backslash sequence",
-	       "script argument parser");
       return 0; /* not reached? */
     }
 }
+#undef FUNC_NAME
 
 
 static char *
 script_read_arg (FILE *f)
+#define FUNC_NAME "script_read_arg"
 {
   int size = 7;
   char *buf = malloc (size + 1);
@@ -275,13 +276,12 @@ script_read_arg (FILE *f)
 
 	case '\t':
 	  free (buf);
-	  scm_wta (SCM_UNDEFINED,
+	  SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
-		   "malformed script: TAB in meta-arguments",
-		   "argument parser");
 	  return 0; /* not reached? */
 	}
     }
 }
+#undef FUNC_NAME
 
 
 static int

libguile/unif.c

@@ -1156,11 +1156,12 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 
 SCM 
 scm_cvref (SCM v, scm_sizet pos, SCM last)
+#define FUNC_NAME "scm_cvref"
 {
   switch SCM_TYP7 (v)
     {
     default:
-      scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
+      SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
     case scm_tc7_bvect:
       if (SCM_BITVEC_REF(v,pos))
 	return SCM_BOOL_T;
@@ -1222,6 +1223,8 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
       }
     }
 }
+#undef FUNC_NAME
+
 
 SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);