libguile/error.c

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