libguile/error.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44
  45 #if HAVE_CONFIG_H
  46 #  include <config.h>
  47 #endif
  48
  49 #include <stdio.h>
  50 #include <errno.h>
  51
  52 #include "libguile/_scm.h"
  53 #include "libguile/pairs.h"
  54 #include "libguile/strings.h"
  55 #include "libguile/throw.h"
  56
  57 #include "libguile/validate.h"
  58 #include "libguile/error.h"
  59
  60 #ifdef HAVE_STRING_H
  61 #include <string.h>
  62 #endif
  63 #ifdef HAVE_UNISTD_H
  64 #include <unistd.h>
  65 #endif
  66
  67 /* For Windows... */
  68 #ifdef HAVE_IO_H
  69 #include <io.h>
  70 #endif
  71 \f
  72
  73 \f
  74 /* {Errors and Exceptional Conditions}
  75  */
  76
  77
  78 /* All errors should pass through here.  */
  79 void
  80 scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest)
  81 {
  82   SCM arg_list;
  83   if (scm_gc_running_p)
  84     {
  85       /* The error occured during GC --- abort */
  86       fprintf (stderr, "Error in %s during GC: %s\n",
  87                subr ? subr : "unknown function",
  88                message ? message : "<empty message>");
  89       abort ();
  90     }
  91   arg_list = scm_list_4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
  92                          message ? scm_makfrom0str (message) : SCM_BOOL_F,
  93                          args,
  94                          rest);
  95   scm_ithrow (key, arg_list, 1);
  96
  97   /* No return, but just in case: */
  98   {
  99     const char msg[] = "guile:scm_error:scm_ithrow returned!\n";
 100
 101     write (2, msg, (sizeof msg) - 1);
 102   }
 103   exit (1);
 104 }
 105
 106 /* Scheme interface to scm_error.  */
 107 SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
 108            (SCM key, SCM subr, SCM message, SCM args, SCM data),
 109             "Raise an error with key @var{key}.  @var{subr} can be a string\n"
 110             "naming the procedure associated with the error, or @code{#f}.\n"
 111             "@var{message} is the error message string, possibly containing\n"
 112             "@code{~S} and @code{~A} escapes.  When an error is reported,\n"
 113             "these are replaced by formatting the corresponding members of\n"
 114             "@var{args}: @code{~A} (was @code{%s} in older versions of\n"
 115             "Guile) formats using @code{display} and @code{~S} (was\n"
 116             "@code{%S}) formats using @code{write}.  @var{data} is a list or\n"
 117             "@code{#f} depending on @var{key}: if @var{key} is\n"
 118             "@code{system-error} then it should be a list containing the\n"
 119             "Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
 120             "should be a list containing the Unix signal number; otherwise\n"
 121             "it will usually be @code{#f}.")
 122 #define FUNC_NAME s_scm_error_scm
 123 {
 124   char *szSubr;
 125   char *szMessage;
 126
 127   SCM_VALIDATE_SYMBOL (1, key);
 128
 129   if (SCM_FALSEP (subr))
 130     {
 131       szSubr = NULL;
 132     }
 133   else if (SCM_SYMBOLP (subr))
 134     {
 135       szSubr = SCM_SYMBOL_CHARS (subr);
 136     }
 137   else
 138     {
 139       SCM_VALIDATE_STRING (2, subr);
 140       szSubr = SCM_STRING_CHARS (subr);
 141     }
 142
 143   if (SCM_FALSEP (message))
 144     {
 145       szMessage = NULL;
 146     }
 147   else
 148     {
 149       SCM_VALIDATE_STRING (2, message);
 150       szMessage = SCM_STRING_CHARS (message);
 151     }
 152
 153   scm_error (key, szSubr, szMessage, args, data);
 154   /* not reached.  */
 155 }
 156 #undef FUNC_NAME
 157
 158 #ifdef __MINGW32__
 159 # include "win32-socket.h"
 160 # define SCM_I_STRERROR(err) \
 161     ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
 162 # define SCM_I_ERRNO() \
 163     (errno ? errno : scm_i_socket_errno ())
 164 #else
 165 # define SCM_I_STRERROR(err) strerror (err)
 166 # define SCM_I_ERRNO() errno
 167 #endif /* __MINGW32__ */
 168
 169 SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
 170             (SCM err),
 171             "Return the Unix error message corresponding to @var{err}, which\n"
 172             "must be an integer value.")
 173 #define FUNC_NAME s_scm_strerror
 174 {
 175   SCM_VALIDATE_INUM (1, err);
 176   return scm_makfrom0str (SCM_I_STRERROR (SCM_INUM (err)));
 177 }
 178 #undef FUNC_NAME
 179
 180 SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
 181 void
 182 scm_syserror (const char *subr)
 183 {
 184   int save_errno = SCM_I_ERRNO ();
 185
 186   scm_error (scm_system_error_key,
 187              subr,
 188              "~A",
 189              scm_cons (scm_makfrom0str (SCM_I_STRERROR (save_errno)), SCM_EOL),
 190              scm_cons (SCM_MAKINUM (save_errno), SCM_EOL));
 191 }
 192
 193 void
 194 scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
 195 {
 196   scm_error (scm_system_error_key,
 197              subr,
 198              message,
 199              args,
 200              scm_cons (SCM_MAKINUM (eno), SCM_EOL));
 201 }
 202
 203 SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 204 void
 205 scm_num_overflow (const char *subr)
 206 {
 207   scm_error (scm_num_overflow_key,
 208              subr,
 209              "Numerical overflow",
 210              SCM_BOOL_F,
 211              SCM_BOOL_F);
 212 }
 213
 214 SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
 215 void
 216 scm_out_of_range (const char *subr, SCM bad_value)
 217 {
 218   scm_error (scm_out_of_range_key,
 219              subr,
 220              "Argument out of range: ~S",
 221              scm_list_1 (bad_value),
 222              SCM_BOOL_F);
 223 }
 224
 225 void
 226 scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
 227 {
 228   scm_error (scm_out_of_range_key,
 229              subr,
 230              "Argument ~S out of range: ~S",
 231              scm_list_2 (pos, bad_value),
 232              SCM_BOOL_F);
 233 }
 234
 235
 236 SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 237 void
 238 scm_wrong_num_args (SCM proc)
 239 {
 240   scm_error (scm_args_number_key,
 241              NULL,
 242              "Wrong number of arguments to ~A",
 243              scm_list_1 (proc),
 244              SCM_BOOL_F);
 245 }
 246
 247
 248 void
 249 scm_error_num_args_subr (const char *subr)
 250 {
 251   scm_error (scm_args_number_key,
 252              NULL,
 253              "Wrong number of arguments to ~A",
 254              scm_list_1 (scm_makfrom0str (subr)),
 255              SCM_BOOL_F);
 256 }
 257
 258
 259 SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 260 void
 261 scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
 262 {
 263   scm_error (scm_arg_type_key,
 264              subr,
 265              (pos == 0) ? "Wrong type argument: ~S"
 266              : "Wrong type argument in position ~A: ~S",
 267              (pos == 0) ? scm_list_1 (bad_value)
 268              : scm_list_2 (SCM_MAKINUM (pos), bad_value),
 269              SCM_BOOL_F);
 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_makfrom0str(szMessage);
 276   if (pos == 0) {
 277     scm_error (scm_arg_type_key,
 278                subr, "Wrong type argument (expecting ~A): ~S",
 279                scm_list_2 (msg, bad_value),
 280                SCM_BOOL_F);
 281   } else {
 282     scm_error (scm_arg_type_key,
 283                subr,
 284                "Wrong type argument in position ~A (expecting ~A): ~S",
 285                scm_list_3 (SCM_MAKINUM (pos), msg, bad_value),
 286                SCM_BOOL_F);
 287   }
 288 }
 289
 290
 291 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 292 void
 293 scm_memory_error (const char *subr)
 294 {
 295   scm_error (scm_memory_alloc_key,
 296              subr,
 297              "Memory allocation error",
 298              SCM_BOOL_F,
 299              SCM_BOOL_F);
 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_err_symbols.c"
 313 #include "libguile/error.x"
 314 }
 315
 316
 317 /*
 318   Local Variables:
 319   c-file-style: "gnu"
 320   End:
 321 */