libguile/error.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010,
   2  *   2012, 2013 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}, @code{wrong-type-arg},\n"
  84             "or @code{keyword-argument-error}, "
  85             "it is a list containing the bad value; otherwise\n"
  86             "it will usually be @code{#f}.")
  87 #define FUNC_NAME s_scm_error_scm
  88 {
  89   if (scm_gc_running_p)
  90     {
  91       /* The error occured during GC --- abort */
  92       fprintf (stderr, "Guile: error during GC.\n"),
  93       abort ();
  94     }
  95
  96   scm_ithrow (key, scm_list_4 (subr, message, args, data), 1);
  97
  98   /* No return, but just in case: */
  99   fprintf (stderr, "Guile scm_ithrow returned!\n");
 100   exit (EXIT_FAILURE);
 101 }
 102 #undef FUNC_NAME
 103
 104 /* strerror may not be thread safe, for instance in glibc (version 2.3.2) an
 105    error number not among the known values results in a string like "Unknown
 106    error 9999" formed in a static buffer, which will be overwritten by a
 107    similar call in another thread.  A test program running two threads with
 108    different unknown error numbers can trip this fairly quickly.
 109
 110    Some systems don't do what glibc does, instead just giving a single
 111    "Unknown error" for unrecognised numbers.  It doesn't seem worth trying
 112    to tell if that's the case, a mutex is reasonably fast, and strerror
 113    isn't needed very often.
 114
 115    strerror_r (when available) could be used, it might be a touch faster
 116    than a frame and a mutex, though there's probably not much
 117    difference.  */
 118
 119 SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
 120             (SCM err),
 121             "Return the Unix error message corresponding to @var{err}, which\n"
 122             "must be an integer value.")
 123 #define FUNC_NAME s_scm_strerror
 124 {
 125   SCM ret;
 126   scm_dynwind_begin (0);
 127   scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
 128
 129   ret = scm_from_locale_string (strerror (scm_to_int (err)));
 130
 131   scm_dynwind_end ();
 132   return ret;
 133 }
 134 #undef FUNC_NAME
 135
 136 SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
 137 void
 138 scm_syserror (const char *subr)
 139 {
 140   SCM err = scm_from_int (errno);
 141
 142   /* It could be that we're getting here because the syscall was
 143      interrupted by a signal.  In that case a signal handler might have
 144      been queued to run.  The signal handler probably throws an
 145      exception.
 146
 147      If we don't try to run the signal handler now, it will run later,
 148      which would result in two exceptions being thrown: this syserror,
 149      and then at some later time the exception thrown by the async
 150      signal handler.
 151
 152      The problem is that we don't know if handling the signal caused an
 153      async to be queued.  By this time scmsigs.c:take_signal will have
 154      written a byte on the fd, but we don't know if the signal-handling
 155      thread has read it off and queued an async.
 156
 157      Ideally we need some API like scm_i_ensure_signals_delivered() to
 158      catch up signal delivery.  Barring that, we just cross our digits
 159      and pray; it could be that we handle the signal in time, and just
 160      throw once, or it could be that we miss the deadline and throw
 161      twice.
 162   */
 163 #ifdef EINTR
 164   if (scm_to_int (err) == EINTR)
 165     SCM_ASYNC_TICK;
 166 #endif
 167
 168   scm_error (scm_system_error_key,
 169              subr,
 170              "~A",
 171              scm_cons (scm_strerror (err), SCM_EOL),
 172              scm_cons (err, SCM_EOL));
 173 }
 174
 175 void
 176 scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
 177 {
 178   /* See above note about the EINTR signal handling race. */
 179 #ifdef EINTR
 180   if (eno == EINTR)
 181     SCM_ASYNC_TICK;
 182 #endif
 183   scm_error (scm_system_error_key,
 184              subr,
 185              message,
 186              args,
 187              scm_cons (scm_from_int (eno), SCM_EOL));
 188 }
 189
 190 SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 191 void
 192 scm_num_overflow (const char *subr)
 193 {
 194   scm_error (scm_num_overflow_key,
 195              subr,
 196              "Numerical overflow",
 197              SCM_BOOL_F,
 198              SCM_BOOL_F);
 199 }
 200
 201 SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
 202 void
 203 scm_out_of_range (const char *subr, SCM bad_value)
 204 {
 205   scm_error (scm_out_of_range_key,
 206              subr,
 207              "Value out of range: ~S",
 208              scm_list_1 (bad_value),
 209              scm_list_1 (bad_value));
 210 }
 211
 212 void
 213 scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
 214 {
 215   scm_error (scm_out_of_range_key,
 216              subr,
 217              "Argument ~A out of range: ~S",
 218              scm_list_2 (pos, bad_value),
 219              scm_list_1 (bad_value));
 220 }
 221
 222
 223 SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 224 void
 225 scm_wrong_num_args (SCM proc)
 226 {
 227   scm_error (scm_args_number_key,
 228              NULL,
 229              "Wrong number of arguments to ~A",
 230              scm_list_1 (proc),
 231              SCM_BOOL_F);
 232 }
 233
 234
 235 void
 236 scm_error_num_args_subr (const char *subr)
 237 {
 238   scm_error (scm_args_number_key,
 239              NULL,
 240              "Wrong number of arguments to ~A",
 241              scm_list_1 (scm_from_locale_string (subr)),
 242              SCM_BOOL_F);
 243 }
 244
 245
 246 SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 247 void
 248 scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
 249 {
 250   scm_error (scm_arg_type_key,
 251              subr,
 252              (pos == 0) ? "Wrong type: ~S"
 253              : "Wrong type argument in position ~A: ~S",
 254              (pos == 0) ? scm_list_1 (bad_value)
 255              : scm_list_2 (scm_from_int (pos), bad_value),
 256              scm_list_1 (bad_value));
 257 }
 258
 259 void
 260 scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
 261 {
 262   scm_error_scm (scm_arg_type_key,
 263                  scm_symbol_to_string (symbol),
 264                  (pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
 265                  : scm_from_locale_string ("Wrong type argument in position ~A: ~S"),
 266                  (pos == 0) ? scm_list_1 (bad_value)
 267                  : scm_list_2 (scm_from_int (pos), bad_value),
 268                  scm_list_1 (bad_value));
 269   scm_remember_upto_here_2 (symbol, bad_value);
 270 }
 271
 272 void
 273 scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
 274 {
 275   SCM msg = scm_from_locale_string (szMessage);
 276   if (pos == 0)
 277     {
 278       scm_error (scm_arg_type_key,
 279                  subr, "Wrong type (expecting ~A): ~S",
 280                  scm_list_2 (msg, bad_value),
 281                  scm_list_1 (bad_value));
 282     }
 283   else
 284     {
 285       scm_error (scm_arg_type_key,
 286                  subr,
 287                  "Wrong type argument in position ~A (expecting ~A): ~S",
 288                  scm_list_3 (scm_from_int (pos), msg, bad_value),
 289                  scm_list_1 (bad_value));
 290     }
 291 }
 292
 293
 294 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 295 void
 296 scm_memory_error (const char *subr)
 297 {
 298   fprintf (stderr, "FATAL: memory error in %s\n", subr);
 299   abort ();
 300 }
 301
 302 SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
 303 void
 304 scm_misc_error (const char *subr, const char *message, SCM args)
 305 {
 306   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 307 }
 308
 309 void
 310 scm_init_error ()
 311 {
 312 #include "libguile/cpp-E.c"
 313 #include "libguile/error.x"
 314 }
 315
 316
 317 /*
 318   Local Variables:
 319   c-file-style: "gnu"
 320   End:
 321 */