libguile/error.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010,
   2  *   2012 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22
  23 #ifdef HAVE_CONFIG_H
  24 #  include <config.h>
  25 #endif
  26
  27 #include <stdlib.h>
  28 #include <stdio.h>
  29 #include <errno.h>
  30
  31 #include "libguile/_scm.h"
  32 #include "libguile/dynwind.h"
  33 #include "libguile/pairs.h"
  34 #include "libguile/strings.h"
  35 #include "libguile/throw.h"
  36
  37 #include "libguile/validate.h"
  38 #include "libguile/error.h"
  39
  40 #ifdef HAVE_STRING_H
  41 #include <string.h>
  42 #endif
  43 #ifdef HAVE_UNISTD_H
  44 #include <unistd.h>
  45 #endif
  46
  47 /* For Windows... */
  48 #ifdef HAVE_IO_H
  49 #include <io.h>
  50 #endif
  51 \f
  52
  53 /* {Errors and Exceptional Conditions}
  54  */
  55
  56
  57 /* Scheme interface to scm_error_scm.  */
  58 void
  59 scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest)
  60 {
  61   scm_error_scm
  62     (key,
  63      (subr == NULL) ? SCM_BOOL_F : scm_from_locale_string (subr),
  64      (message == NULL) ? SCM_BOOL_F : scm_from_locale_string (message),
  65      args, rest);
  66 }
  67
  68 /* All errors should pass through here.  */
  69 SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
  70            (SCM key, SCM subr, SCM message, SCM args, SCM data),
  71             "Raise an error with key @var{key}.  @var{subr} can be a string\n"
  72             "naming the procedure associated with the error, or @code{#f}.\n"
  73             "@var{message} is the error message string, possibly containing\n"
  74             "@code{~S} and @code{~A} escapes.  When an error is reported,\n"
  75             "these are replaced by formatting the corresponding members of\n"
  76             "@var{args}: @code{~A} (was @code{%s} in older versions of\n"
  77             "Guile) formats using @code{display} and @code{~S} (was\n"
  78             "@code{%S}) formats using @code{write}.  @var{data} is a list or\n"
  79             "@code{#f} depending on @var{key}: if @var{key} is\n"
  80             "@code{system-error} then it should be a list containing the\n"
  81             "Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
  82             "should be a list containing the Unix signal number; If\n"
  83             "@var{key} is @code{out-of-range} or @code{wrong-type-arg},\n"
  84             "it is a list containing the bad value; otherwise\n"
  85             "it will usually be @code{#f}.")
  86 #define FUNC_NAME s_scm_error_scm
  87 {
  88   if (scm_gc_running_p)
  89     {
  90       /* The error occured during GC --- abort */
  91       fprintf (stderr, "Guile: error during GC.\n"),
  92       abort ();
  93     }
  94
  95   scm_ithrow (key, scm_list_4 (subr, message, args, data), 1);
  96
  97   /* No return, but just in case: */
  98   fprintf (stderr, "Guile scm_ithrow returned!\n");
  99   exit (EXIT_FAILURE);
 100 }
 101 #undef FUNC_NAME
 102
 103 #if defined __MINGW32__ && defined HAVE_NETWORKING
 104 # include "win32-socket.h"
 105 # define SCM_I_STRERROR(err) \
 106     ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
 107 # define SCM_I_ERRNO() \
 108     (errno ? errno : scm_i_socket_errno ())
 109 #else
 110 # define SCM_I_STRERROR(err) strerror (err)
 111 # define SCM_I_ERRNO() errno
 112 #endif /* __MINGW32__ */
 113
 114 /* strerror may not be thread safe, for instance in glibc (version 2.3.2) an
 115    error number not among the known values results in a string like "Unknown
 116    error 9999" formed in a static buffer, which will be overwritten by a
 117    similar call in another thread.  A test program running two threads with
 118    different unknown error numbers can trip this fairly quickly.
 119
 120    Some systems don't do what glibc does, instead just giving a single
 121    "Unknown error" for unrecognised numbers.  It doesn't seem worth trying
 122    to tell if that's the case, a mutex is reasonably fast, and strerror
 123    isn't needed very often.
 124
 125    strerror_r (when available) could be used, it might be a touch faster
 126    than a frame and a mutex, though there's probably not much
 127    difference.  */
 128
 129 SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
 130             (SCM err),
 131             "Return the Unix error message corresponding to @var{err}, which\n"
 132             "must be an integer value.")
 133 #define FUNC_NAME s_scm_strerror
 134 {
 135   SCM ret;
 136   scm_dynwind_begin (0);
 137   scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
 138
 139   ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
 140
 141   scm_dynwind_end ();
 142   return ret;
 143 }
 144 #undef FUNC_NAME
 145
 146 SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
 147 void
 148 scm_syserror (const char *subr)
 149 {
 150   SCM err = scm_from_int (SCM_I_ERRNO ());
 151
 152   /* It could be that we're getting here because the syscall was
 153      interrupted by a signal.  In that case a signal handler might have
 154      been queued to run.  The signal handler probably throws an
 155      exception.
 156
 157      If we don't try to run the signal handler now, it will run later,
 158      which would result in two exceptions being thrown: this syserror,
 159      and then at some later time the exception thrown by the async
 160      signal handler.
 161
 162      The problem is that we don't know if handling the signal caused an
 163      async to be queued.  By this time scmsigs.c:take_signal will have
 164      written a byte on the fd, but we don't know if the signal-handling
 165      thread has read it off and queued an async.
 166
 167      Ideally we need some API like scm_i_ensure_signals_delivered() to
 168      catch up signal delivery.  Barring that, we just cross our digits
 169      and pray; it could be that we handle the signal in time, and just
 170      throw once, or it could be that we miss the deadline and throw
 171      twice.
 172   */
 173 #ifdef EINTR
 174   if (scm_to_int (err) == EINTR)
 175     SCM_ASYNC_TICK;
 176 #endif
 177
 178   scm_error (scm_system_error_key,
 179              subr,
 180              "~A",
 181              scm_cons (scm_strerror (err), SCM_EOL),
 182              scm_cons (err, SCM_EOL));
 183 }
 184
 185 void
 186 scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
 187 {
 188   /* See above note about the EINTR signal handling race. */
 189 #ifdef EINTR
 190   if (eno == EINTR)
 191     SCM_ASYNC_TICK;
 192 #endif
 193   scm_error (scm_system_error_key,
 194              subr,
 195              message,
 196              args,
 197              scm_cons (scm_from_int (eno), SCM_EOL));
 198 }
 199
 200 SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 201 void
 202 scm_num_overflow (const char *subr)
 203 {
 204   scm_error (scm_num_overflow_key,
 205              subr,
 206              "Numerical overflow",
 207              SCM_BOOL_F,
 208              SCM_BOOL_F);
 209 }
 210
 211 SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
 212 void
 213 scm_out_of_range (const char *subr, SCM bad_value)
 214 {
 215   scm_error (scm_out_of_range_key,
 216              subr,
 217              "Value out of range: ~S",
 218              scm_list_1 (bad_value),
 219              scm_list_1 (bad_value));
 220 }
 221
 222 void
 223 scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
 224 {
 225   scm_error (scm_out_of_range_key,
 226              subr,
 227              "Argument ~A out of range: ~S",
 228              scm_list_2 (pos, bad_value),
 229              scm_list_1 (bad_value));
 230 }
 231
 232
 233 SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 234 void
 235 scm_wrong_num_args (SCM proc)
 236 {
 237   scm_error (scm_args_number_key,
 238              NULL,
 239              "Wrong number of arguments to ~A",
 240              scm_list_1 (proc),
 241              SCM_BOOL_F);
 242 }
 243
 244
 245 void
 246 scm_error_num_args_subr (const char *subr)
 247 {
 248   scm_error (scm_args_number_key,
 249              NULL,
 250              "Wrong number of arguments to ~A",
 251              scm_list_1 (scm_from_locale_string (subr)),
 252              SCM_BOOL_F);
 253 }
 254
 255
 256 SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 257 void
 258 scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
 259 {
 260   scm_error (scm_arg_type_key,
 261              subr,
 262              (pos == 0) ? "Wrong type: ~S"
 263              : "Wrong type argument in position ~A: ~S",
 264              (pos == 0) ? scm_list_1 (bad_value)
 265              : scm_list_2 (scm_from_int (pos), bad_value),
 266              scm_list_1 (bad_value));
 267 }
 268
 269 void
 270 scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
 271 {
 272   scm_error_scm (scm_arg_type_key,
 273                  scm_symbol_to_string (symbol),
 274                  (pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
 275                  : scm_from_locale_string ("Wrong type argument in position ~A: ~S"),
 276                  (pos == 0) ? scm_list_1 (bad_value)
 277                  : scm_list_2 (scm_from_int (pos), bad_value),
 278                  scm_list_1 (bad_value));
 279   scm_remember_upto_here_2 (symbol, bad_value);
 280 }
 281
 282 void
 283 scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
 284 {
 285   SCM msg = scm_from_locale_string (szMessage);
 286   if (pos == 0)
 287     {
 288       scm_error (scm_arg_type_key,
 289                  subr, "Wrong type (expecting ~A): ~S",
 290                  scm_list_2 (msg, bad_value),
 291                  scm_list_1 (bad_value));
 292     }
 293   else
 294     {
 295       scm_error (scm_arg_type_key,
 296                  subr,
 297                  "Wrong type argument in position ~A (expecting ~A): ~S",
 298                  scm_list_3 (scm_from_int (pos), msg, bad_value),
 299                  scm_list_1 (bad_value));
 300     }
 301 }
 302
 303
 304 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 305 void
 306 scm_memory_error (const char *subr)
 307 {
 308   fprintf (stderr, "FATAL: memory error in %s\n", subr);
 309   abort ();
 310 }
 311
 312 SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
 313 void
 314 scm_misc_error (const char *subr, const char *message, SCM args)
 315 {
 316   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 317 }
 318
 319 void
 320 scm_init_error ()
 321 {
 322 #include "libguile/cpp-E.c"
 323 #include "libguile/error.x"
 324 }
 325
 326
 327 /*
 328   Local Variables:
 329   c-file-style: "gnu"
 330   End:
 331 */