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   return scm_makfrom0str (SCM_I_STRERROR (scm_to_int (err)));
 152 }
 153 #undef FUNC_NAME
 154
 155 SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
 156 void
 157 scm_syserror (const char *subr)
 158 {
 159   int save_errno = SCM_I_ERRNO ();
 160
 161   scm_error (scm_system_error_key,
 162              subr,
 163              "~A",
 164              scm_cons (scm_makfrom0str (SCM_I_STRERROR (save_errno)), SCM_EOL),
 165              scm_cons (scm_from_int (save_errno), SCM_EOL));
 166 }
 167
 168 void
 169 scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
 170 {
 171   scm_error (scm_system_error_key,
 172              subr,
 173              message,
 174              args,
 175              scm_cons (scm_from_int (eno), SCM_EOL));
 176 }
 177
 178 SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 179 void
 180 scm_num_overflow (const char *subr)
 181 {
 182   scm_error (scm_num_overflow_key,
 183              subr,
 184              "Numerical overflow",
 185              SCM_BOOL_F,
 186              SCM_BOOL_F);
 187 }
 188
 189 SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
 190 void
 191 scm_out_of_range (const char *subr, SCM bad_value)
 192 {
 193   scm_error (scm_out_of_range_key,
 194              subr,
 195              "Argument out of range: ~S",
 196              scm_list_1 (bad_value),
 197              SCM_BOOL_F);
 198 }
 199
 200 void
 201 scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
 202 {
 203   scm_error (scm_out_of_range_key,
 204              subr,
 205              "Argument ~S out of range: ~S",
 206              scm_list_2 (pos, bad_value),
 207              SCM_BOOL_F);
 208 }
 209
 210
 211 SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 212 void
 213 scm_wrong_num_args (SCM proc)
 214 {
 215   scm_error (scm_args_number_key,
 216              NULL,
 217              "Wrong number of arguments to ~A",
 218              scm_list_1 (proc),
 219              SCM_BOOL_F);
 220 }
 221
 222
 223 void
 224 scm_error_num_args_subr (const char *subr)
 225 {
 226   scm_error (scm_args_number_key,
 227              NULL,
 228              "Wrong number of arguments to ~A",
 229              scm_list_1 (scm_makfrom0str (subr)),
 230              SCM_BOOL_F);
 231 }
 232
 233
 234 SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 235 void
 236 scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
 237 {
 238   scm_error (scm_arg_type_key,
 239              subr,
 240              (pos == 0) ? "Wrong type argument: ~S"
 241              : "Wrong type argument in position ~A: ~S",
 242              (pos == 0) ? scm_list_1 (bad_value)
 243              : scm_list_2 (SCM_I_MAKINUM (pos), bad_value),
 244              SCM_BOOL_F);
 245 }
 246
 247 void
 248 scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
 249 {
 250   SCM msg = scm_makfrom0str(szMessage);
 251   if (pos == 0) {
 252     scm_error (scm_arg_type_key,
 253                subr, "Wrong type argument (expecting ~A): ~S",
 254                scm_list_2 (msg, bad_value),
 255                SCM_BOOL_F);
 256   } else {
 257     scm_error (scm_arg_type_key,
 258                subr,
 259                "Wrong type argument in position ~A (expecting ~A): ~S",
 260                scm_list_3 (SCM_I_MAKINUM (pos), msg, bad_value),
 261                SCM_BOOL_F);
 262   }
 263 }
 264
 265
 266 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 267 void
 268 scm_memory_error (const char *subr)
 269 {
 270   scm_error (scm_memory_alloc_key,
 271              subr,
 272              "Memory allocation error",
 273              SCM_BOOL_F,
 274              SCM_BOOL_F);
 275 }
 276
 277 SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
 278 void
 279 scm_misc_error (const char *subr, const char *message, SCM args)
 280 {
 281   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 282 }
 283
 284 void
 285 scm_init_error ()
 286 {
 287 #include "libguile/cpp_err_symbols.c"
 288 #include "libguile/error.x"
 289 }
 290
 291
 292 /*
 293   Local Variables:
 294   c-file-style: "gnu"
 295   End:
 296 */