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