libguile/error.c

   1 /*      Copyright (C) 1995,1996,1997,1998 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 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "pairs.h"
  46 #include "genio.h"
  47 #include "throw.h"
  48
  49 #include "error.h"
  50
  51 #ifdef HAVE_UNISTD_H
  52 #include <unistd.h>
  53 #endif
  54 \f
  55
  56 \f
  57 /* {Errors and Exceptional Conditions}
  58  */
  59
  60
  61 extern int errno;
  62
  63 /* All errors should pass through here.  */
  64 void
  65 scm_error (key, subr, message, args, rest)
  66      SCM key;
  67      const char *subr;
  68      const char *message;
  69      SCM args;
  70      SCM rest;
  71 {
  72   SCM arg_list;
  73   arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
  74                           message ? scm_makfrom0str (message) : SCM_BOOL_F,
  75                           args,
  76                           rest,
  77                           SCM_UNDEFINED);
  78   scm_ithrow (key, arg_list, 1);
  79
  80   /* No return, but just in case: */
  81   {
  82     const char msg[] = "guile:scm_error:scm_ithrow returned!\n";
  83
  84     write (2, msg, (sizeof msg) - 1);
  85   }
  86   exit (1);
  87 }
  88
  89 /* Scheme interface to scm_error.  */
  90 SCM_PROC(s_error_scm, "scm-error", 5, 0, 0, scm_error_scm);
  91 SCM
  92 scm_error_scm (key, subr, message, args, rest)
  93      SCM key;
  94      SCM subr;
  95      SCM message;
  96      SCM args;
  97      SCM rest;
  98 {
  99   SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_error_scm);
 100   SCM_ASSERT (SCM_FALSEP (subr) || (SCM_NIMP (subr) && SCM_ROSTRINGP (subr)),
 101               subr, SCM_ARG2, s_error_scm);
 102   SCM_ASSERT (SCM_FALSEP (message)
 103               || (SCM_NIMP (message) && SCM_ROSTRINGP (message)),
 104               message, SCM_ARG3, s_error_scm);
 105
 106   SCM_COERCE_SUBSTR (message);
 107
 108   scm_error (key,
 109              (SCM_FALSEP (subr)) ? NULL : SCM_ROCHARS (subr),
 110              (SCM_FALSEP (message)) ? NULL : SCM_ROCHARS (message),
 111              args,
 112              rest);
 113   /* not reached.  */
 114 }
 115
 116 SCM_PROC (s_strerror, "strerror", 1, 0, 0, scm_strerror);
 117 SCM
 118 scm_strerror (SCM err)
 119 {
 120   SCM_ASSERT (SCM_INUMP (err), err, SCM_ARG1, s_strerror);
 121   return scm_makfrom0str (strerror (SCM_INUM (err)));
 122 }
 123
 124 SCM_SYMBOL (scm_system_error_key, "system-error");
 125 void
 126 scm_syserror (subr)
 127      const char *subr;
 128 {
 129   scm_error (scm_system_error_key,
 130              subr,
 131              "%s",
 132              scm_cons (scm_makfrom0str (strerror (errno)), SCM_EOL),
 133              scm_cons (SCM_MAKINUM (errno), SCM_EOL));
 134 }
 135
 136 void
 137 scm_syserror_msg (subr, message, args, eno)
 138      const char *subr;
 139      const char *message;
 140      SCM args;
 141      int eno;
 142 {
 143   scm_error (scm_system_error_key,
 144              subr,
 145              message,
 146              args,
 147              scm_cons (SCM_MAKINUM (eno), SCM_EOL));
 148 }
 149
 150 void
 151 scm_sysmissing (subr)
 152      const char *subr;
 153 {
 154 #ifdef ENOSYS
 155   scm_error (scm_system_error_key,
 156              subr,
 157              "%s",
 158              scm_cons (scm_makfrom0str (strerror (ENOSYS)), SCM_EOL),
 159              scm_cons (SCM_MAKINUM (ENOSYS), SCM_EOL));
 160 #else
 161   scm_error (scm_system_error_key,
 162              subr,
 163              "Missing function",
 164              SCM_BOOL_F,
 165              scm_cons (SCM_MAKINUM (0), SCM_EOL));
 166 #endif
 167 }
 168
 169 SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 170 void
 171 scm_num_overflow (subr)
 172   const char *subr;
 173 {
 174   scm_error (scm_num_overflow_key,
 175              subr,
 176              "Numerical overflow",
 177              SCM_BOOL_F,
 178              SCM_BOOL_F);
 179 }
 180
 181 SCM_SYMBOL (scm_out_of_range_key, "out-of-range");
 182 void
 183 scm_out_of_range (subr, bad_value)
 184      const char *subr;
 185      SCM bad_value;
 186 {
 187   scm_error (scm_out_of_range_key,
 188              subr,
 189              "Argument out of range: %S",
 190              scm_cons (bad_value, SCM_EOL),
 191              SCM_BOOL_F);
 192 }
 193
 194 SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 195 void
 196 scm_wrong_num_args (proc)
 197      SCM proc;
 198 {
 199   scm_error (scm_args_number_key,
 200              NULL,
 201              "Wrong number of arguments to %s",
 202              scm_cons (proc, SCM_EOL),
 203              SCM_BOOL_F);
 204 }
 205
 206 SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 207 void
 208 scm_wrong_type_arg (subr, pos, bad_value)
 209      const char *subr;
 210      int pos;
 211      SCM bad_value;
 212 {
 213   scm_error (scm_arg_type_key,
 214              subr,
 215              (pos == 0) ? "Wrong type argument: %S"
 216              : "Wrong type argument in position %s: %S",
 217              (pos == 0) ? scm_cons (bad_value, SCM_EOL)
 218              : scm_cons (SCM_MAKINUM (pos), scm_cons (bad_value, SCM_EOL)),
 219              SCM_BOOL_F);
 220 }
 221
 222 SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 223 void
 224 scm_memory_error (subr)
 225      const char *subr;
 226 {
 227   scm_error (scm_memory_alloc_key,
 228              subr,
 229              "Memory allocation error",
 230              SCM_BOOL_F,
 231              SCM_BOOL_F);
 232 }
 233
 234 SCM_SYMBOL (scm_misc_error_key, "misc-error");
 235 void
 236 scm_misc_error (subr, message, args)
 237      const char *subr;
 238      const char *message;
 239      SCM args;
 240 {
 241   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 242 }
 243
 244 /* implements the SCM_ASSERT interface.  */
 245 SCM
 246 scm_wta (arg, pos, s_subr)
 247      SCM arg;
 248      const char *pos;
 249      const char *s_subr;
 250 {
 251   if (!s_subr || !*s_subr)
 252     s_subr = NULL;
 253   if ((~0x1fL) & (long) pos)
 254     {
 255       /* error string supplied.  */
 256       scm_misc_error (s_subr, pos, SCM_LIST1 (arg));
 257     }
 258   else
 259     {
 260       /* numerical error code.  */
 261       int error = (long) pos;
 262
 263       switch (error)
 264         {
 265         case SCM_ARGn:
 266           scm_wrong_type_arg (s_subr, 0, arg);
 267         case SCM_ARG1:
 268           scm_wrong_type_arg (s_subr, 1, arg);
 269         case SCM_ARG2:
 270           scm_wrong_type_arg (s_subr, 2, arg);
 271         case SCM_ARG3:
 272           scm_wrong_type_arg (s_subr, 3, arg);
 273         case SCM_ARG4:
 274           scm_wrong_type_arg (s_subr, 4, arg);
 275         case SCM_ARG5:
 276           scm_wrong_type_arg (s_subr, 5, arg);
 277         case SCM_ARG6:
 278           scm_wrong_type_arg (s_subr, 6, arg);
 279         case SCM_ARG7:
 280           scm_wrong_type_arg (s_subr, 7, arg);
 281         case SCM_WNA:
 282           scm_wrong_num_args (arg);
 283         case SCM_OUTOFRANGE:
 284           scm_out_of_range (s_subr, arg);
 285         case SCM_NALLOC:
 286           scm_memory_error (s_subr);
 287         default:
 288           /* this shouldn't happen.  */
 289           scm_misc_error (s_subr, "Unknown error", SCM_EOL);
 290         }
 291     }
 292   return SCM_UNSPECIFIED;
 293 }
 294
 295 void
 296 scm_init_error ()
 297 {
 298 #include "cpp_err_symbols.c"
 299 #include "error.x"
 300 }
 301