libguile/error.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44
  45 #include <stdio.h>
  46 #include <errno.h>
  47
  48 #include "libguile/_scm.h"
  49 #include "libguile/pairs.h"
  50 #include "libguile/strings.h"
  51 #include "libguile/throw.h"
  52
  53 #include "libguile/validate.h"
  54 #include "libguile/error.h"
  55
  56 #ifdef HAVE_STRING_H
  57 #include <string.h>
  58 #endif
  59 #ifdef HAVE_UNISTD_H
  60 #include <unistd.h>
  61 #endif
  62
  63 /* For Windows... */
  64 #ifdef HAVE_IO_H
  65 #include <io.h>
  66 #endif
  67 \f
  68
  69 \f
  70 /* {Errors and Exceptional Conditions}
  71  */
  72
  73
  74 /* All errors should pass through here.  */
  75 void
  76 scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest)
  77 {
  78   SCM arg_list;
  79   if (scm_gc_running_p)
  80     {
  81       /* The error occured during GC --- abort */
  82       fprintf (stderr, "Error in %s during GC: %s\n",
  83                subr ? subr : "unknown function",
  84                message ? message : "<empty message>");
  85       abort ();
  86     }
  87   arg_list = scm_list_4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
  88                          message ? scm_makfrom0str (message) : SCM_BOOL_F,
  89                          args,
  90                          rest);
  91   scm_ithrow (key, arg_list, 1);
  92
  93   /* No return, but just in case: */
  94   {
  95     const char msg[] = "guile:scm_error:scm_ithrow returned!\n";
  96
  97     write (2, msg, (sizeof msg) - 1);
  98   }
  99   exit (1);
 100 }
 101
 102 /* Scheme interface to scm_error.  */
 103 SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
 104            (SCM key, SCM subr, SCM message, SCM args, SCM data),
 105             "Raise an error with key @var{key}.  @var{subr} can be a string\n"
 106             "naming the procedure associated with the error, or @code{#f}.\n"
 107             "@var{message} is the error message string, possibly containing\n"
 108             "@code{~S} and @code{~A} escapes.  When an error is reported,\n"
 109             "these are replaced by formatting the corresponding members of\n"
 110             "@var{args}: @code{~A} (was @code{%s} in older versions of\n"
 111             "Guile) formats using @code{display} and @code{~S} (was\n"
 112             "@code{%S}) formats using @code{write}.  @var{data} is a list or\n"
 113             "@code{#f} depending on @var{key}: if @var{key} is\n"
 114             "@code{system-error} then it should be a list containing the\n"
 115             "Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
 116             "should be a list containing the Unix signal number; otherwise\n"
 117             "it will usually be @code{#f}.")
 118 #define FUNC_NAME s_scm_error_scm
 119 {
 120   char *szSubr;
 121   char *szMessage;
 122
 123   SCM_VALIDATE_SYMBOL (1, key);
 124
 125   if (SCM_FALSEP (subr))
 126     {
 127       szSubr = NULL;
 128     }
 129   else if (SCM_SYMBOLP (subr))
 130     {
 131       szSubr = SCM_SYMBOL_CHARS (subr);
 132     }
 133   else
 134     {
 135       SCM_VALIDATE_STRING (2, subr);
 136       szSubr = SCM_STRING_CHARS (subr);
 137     }
 138
 139   if (SCM_FALSEP (message))
 140     {
 141       szMessage = NULL;
 142     }
 143   else
 144     {
 145       SCM_VALIDATE_STRING (2, message);
 146       szMessage = SCM_STRING_CHARS (message);
 147     }
 148
 149   scm_error (key, szSubr, szMessage, args, data);
 150   /* not reached.  */
 151 }
 152 #undef FUNC_NAME
 153
 154 #ifdef __MINGW32__
 155 # include "win32-socket.h"
 156 # define SCM_I_STRERROR(err) \
 157     ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
 158 # define SCM_I_ERRNO() \
 159     (errno ? errno : scm_i_socket_errno ())
 160 #else
 161 # define SCM_I_STRERROR(err) strerror (err)
 162 # define SCM_I_ERRNO() errno
 163 #endif /* __MINGW32__ */
 164
 165 SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
 166             (SCM err),
 167             "Return the Unix error message corresponding to @var{err}, which\n"
 168             "must be an integer value.")
 169 #define FUNC_NAME s_scm_strerror
 170 {
 171   SCM_VALIDATE_INUM (1,err);
 172   return scm_makfrom0str (SCM_I_STRERROR (SCM_INUM (err)));
 173 }
 174 #undef FUNC_NAME
 175
 176 SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
 177 void
 178 scm_syserror (const char *subr)
 179 {
 180   int save_errno = SCM_I_ERRNO ();
 181
 182   scm_error (scm_system_error_key,
 183              subr,
 184              "~A",
 185              scm_cons (scm_makfrom0str (SCM_I_STRERROR (save_errno)), SCM_EOL),
 186              scm_cons (SCM_MAKINUM (save_errno), SCM_EOL));
 187 }
 188
 189 void
 190 scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
 191 {
 192   scm_error (scm_system_error_key,
 193              subr,
 194              message,
 195              args,
 196              scm_cons (SCM_MAKINUM (eno), SCM_EOL));
 197 }
 198
 199 SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 200 void
 201 scm_num_overflow (const char *subr)
 202 {
 203   scm_error (scm_num_overflow_key,
 204              subr,
 205              "Numerical overflow",
 206              SCM_BOOL_F,
 207              SCM_BOOL_F);
 208 }
 209
 210 SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
 211 void
 212 scm_out_of_range (const char *subr, SCM bad_value)
 213 {
 214   scm_error (scm_out_of_range_key,
 215              subr,
 216              "Argument out of range: ~S",
 217              scm_list_1 (bad_value),
 218              SCM_BOOL_F);
 219 }
 220
 221 void
 222 scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
 223 {
 224   scm_error (scm_out_of_range_key,
 225              subr,
 226              "Argument ~S out of range: ~S",
 227              scm_list_2 (pos,bad_value),
 228              SCM_BOOL_F);
 229 }
 230
 231
 232 SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 233 void
 234 scm_wrong_num_args (SCM proc)
 235 {
 236   scm_error (scm_args_number_key,
 237              NULL,
 238              "Wrong number of arguments to ~A",
 239              scm_list_1 (proc),
 240              SCM_BOOL_F);
 241 }
 242
 243
 244 void
 245 scm_error_num_args_subr (const char *subr)
 246 {
 247   scm_error (scm_args_number_key,
 248              NULL,
 249              "Wrong number of arguments to ~A",
 250              scm_list_1 (scm_makfrom0str (subr)),
 251              SCM_BOOL_F);
 252 }
 253
 254
 255 SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 256 void
 257 scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
 258 {
 259   scm_error (scm_arg_type_key,
 260              subr,
 261              (pos == 0) ? "Wrong type argument: ~S"
 262              : "Wrong type argument in position ~A: ~S",
 263              (pos == 0) ? scm_list_1 (bad_value)
 264              : scm_list_2 (SCM_MAKINUM (pos), bad_value),
 265              SCM_BOOL_F);
 266 }
 267
 268 void
 269 scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
 270 {
 271   SCM msg = scm_makfrom0str(szMessage);
 272   if (pos == 0) {
 273     scm_error (scm_arg_type_key,
 274                subr, "Wrong type argument (expecting ~A): ~S",
 275                scm_list_2 (msg, bad_value),
 276                SCM_BOOL_F);
 277   } else {
 278     scm_error (scm_arg_type_key,
 279                subr,
 280                "Wrong type argument in position ~A (expecting ~A): ~S",
 281                scm_list_3 (SCM_MAKINUM (pos), msg, bad_value),
 282                SCM_BOOL_F);
 283   }
 284 }
 285
 286
 287 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 288 void
 289 scm_memory_error (const char *subr)
 290 {
 291   scm_error (scm_memory_alloc_key,
 292              subr,
 293              "Memory allocation error",
 294              SCM_BOOL_F,
 295              SCM_BOOL_F);
 296 }
 297
 298 SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
 299 void
 300 scm_misc_error (const char *subr, const char *message, SCM args)
 301 {
 302   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 303 }
 304
 305 void
 306 scm_init_error ()
 307 {
 308 #include "libguile/cpp_err_symbols.c"
 309 #ifndef SCM_MAGIC_SNARFER
 310 #include "libguile/error.x"
 311 #endif
 312 }
 313
 314
 315 /*
 316   Local Variables:
 317   c-file-style: "gnu"
 318   End:
 319 */