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