libguile/error.c

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