libguile/error.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010,
   2  *   2012, 2013, 2014 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   scm_dynwind_begin (0);
 125   scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
 126
 127   ret = scm_from_locale_string (strerror (scm_to_int (err)));
 128
 129   scm_dynwind_end ();
 130   return ret;
 131 }
 132 #undef FUNC_NAME
 133
 134 SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
 135 void
 136 scm_syserror (const char *subr)
 137 {
 138   SCM err = scm_from_int (errno);
 139
 140   /* It could be that we're getting here because the syscall was
 141      interrupted by a signal.  In that case a signal handler might have
 142      been queued to run.  The signal handler probably throws an
 143      exception.
 144
 145      If we don't try to run the signal handler now, it will run later,
 146      which would result in two exceptions being thrown: this syserror,
 147      and then at some later time the exception thrown by the async
 148      signal handler.
 149
 150      The problem is that we don't know if handling the signal caused an
 151      async to be queued.  By this time scmsigs.c:take_signal will have
 152      written a byte on the fd, but we don't know if the signal-handling
 153      thread has read it off and queued an async.
 154
 155      Ideally we need some API like scm_i_ensure_signals_delivered() to
 156      catch up signal delivery.  Barring that, we just cross our digits
 157      and pray; it could be that we handle the signal in time, and just
 158      throw once, or it could be that we miss the deadline and throw
 159      twice.
 160   */
 161 #ifdef EINTR
 162   if (scm_to_int (err) == EINTR)
 163     SCM_ASYNC_TICK;
 164 #endif
 165
 166   scm_error (scm_system_error_key,
 167              subr,
 168              "~A",
 169              scm_cons (scm_strerror (err), SCM_EOL),
 170              scm_cons (err, SCM_EOL));
 171 }
 172
 173 void
 174 scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
 175 {
 176   /* See above note about the EINTR signal handling race. */
 177 #ifdef EINTR
 178   if (eno == EINTR)
 179     SCM_ASYNC_TICK;
 180 #endif
 181   scm_error (scm_system_error_key,
 182              subr,
 183              message,
 184              args,
 185              scm_cons (scm_from_int (eno), SCM_EOL));
 186 }
 187
 188 SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 189 void
 190 scm_num_overflow (const char *subr)
 191 {
 192   scm_error (scm_num_overflow_key,
 193              subr,
 194              "Numerical overflow",
 195              SCM_BOOL_F,
 196              SCM_BOOL_F);
 197 }
 198
 199 SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
 200 void
 201 scm_out_of_range (const char *subr, SCM bad_value)
 202 {
 203   scm_error (scm_out_of_range_key,
 204              subr,
 205              "Value out of range: ~S",
 206              scm_list_1 (bad_value),
 207              scm_list_1 (bad_value));
 208 }
 209
 210 void
 211 scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
 212 {
 213   scm_error (scm_out_of_range_key,
 214              subr,
 215              "Argument ~A out of range: ~S",
 216              scm_list_2 (pos, bad_value),
 217              scm_list_1 (bad_value));
 218 }
 219
 220
 221 SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 222 void
 223 scm_wrong_num_args (SCM proc)
 224 {
 225   scm_error (scm_args_number_key,
 226              NULL,
 227              "Wrong number of arguments to ~A",
 228              scm_list_1 (proc),
 229              SCM_BOOL_F);
 230 }
 231
 232
 233 void
 234 scm_error_num_args_subr (const char *subr)
 235 {
 236   scm_error (scm_args_number_key,
 237              NULL,
 238              "Wrong number of arguments to ~A",
 239              scm_list_1 (scm_from_locale_string (subr)),
 240              SCM_BOOL_F);
 241 }
 242
 243
 244 SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 245 void
 246 scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
 247 {
 248   scm_error (scm_arg_type_key,
 249              subr,
 250              (pos == 0) ? "Wrong type: ~S"
 251              : "Wrong type argument in position ~A: ~S",
 252              (pos == 0) ? scm_list_1 (bad_value)
 253              : scm_list_2 (scm_from_int (pos), bad_value),
 254              scm_list_1 (bad_value));
 255 }
 256
 257 void
 258 scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
 259 {
 260   scm_error_scm (scm_arg_type_key,
 261                  scm_symbol_to_string (symbol),
 262                  (pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
 263                  : scm_from_locale_string ("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   scm_remember_upto_here_2 (symbol, bad_value);
 268 }
 269
 270 void
 271 scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
 272 {
 273   SCM msg = scm_from_locale_string (szMessage);
 274   if (pos == 0)
 275     {
 276       scm_error (scm_arg_type_key,
 277                  subr, "Wrong type (expecting ~A): ~S",
 278                  scm_list_2 (msg, bad_value),
 279                  scm_list_1 (bad_value));
 280     }
 281   else
 282     {
 283       scm_error (scm_arg_type_key,
 284                  subr,
 285                  "Wrong type argument in position ~A (expecting ~A): ~S",
 286                  scm_list_3 (scm_from_int (pos), msg, bad_value),
 287                  scm_list_1 (bad_value));
 288     }
 289 }
 290
 291
 292 SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
 293 void
 294 scm_misc_error (const char *subr, const char *message, SCM args)
 295 {
 296   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 297 }
 298
 299 void
 300 scm_init_error ()
 301 {
 302 #include "libguile/cpp-E.c"
 303 #include "libguile/error.x"
 304 }
 305
 306
 307 /*
 308   Local Variables:
 309   c-file-style: "gnu"
 310   End:
 311 */