| 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_memory_alloc_key, "memory-allocation-error"); |
| 296 | void |
| 297 | scm_memory_error (const char *subr) |
| 298 | { |
| 299 | fprintf (stderr, "FATAL: memory error in %s\n", subr); |
| 300 | abort (); |
| 301 | } |
| 302 | |
| 303 | SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error"); |
| 304 | void |
| 305 | scm_misc_error (const char *subr, const char *message, SCM args) |
| 306 | { |
| 307 | scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F); |
| 308 | } |
| 309 | |
| 310 | void |
| 311 | scm_init_error () |
| 312 | { |
| 313 | #include "libguile/cpp-E.c" |
| 314 | #include "libguile/error.x" |
| 315 | } |
| 316 | |
| 317 | |
| 318 | /* |
| 319 | Local Variables: |
| 320 | c-file-style: "gnu" |
| 321 | End: |
| 322 | */ |