libguile/error.c

   1 /*      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  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 /* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
  62  * when the interpreter is not running at all.
  63  */
  64 int scm_ints_disabled = 1;
  65
  66 extern int errno;
  67
  68 static void err_head SCM_P ((char *str));
  69
  70 static void
  71 err_head (str)
  72      char *str;
  73 {
  74   int oerrno = errno;
  75   if (SCM_NIMP (scm_cur_outp))
  76     scm_fflush (scm_cur_outp);
  77   scm_gen_putc ('\n', scm_cur_errp);
  78 #if 0
  79   if (SCM_BOOL_F != *scm_loc_loadpath)
  80     {
  81       scm_prin1 (*scm_loc_loadpath, scm_cur_errp, 1);
  82       scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp);
  83       scm_intprint ((long) scm_linum, 10, scm_cur_errp);
  84       scm_gen_puts (scm_regular_string, ": ", scm_cur_errp);
  85     }
  86 #endif
  87   scm_fflush (scm_cur_errp);
  88   errno = oerrno;
  89   if (scm_cur_errp == scm_def_errp)
  90     {
  91       if (errno > 0)
  92         perror (str);
  93       fflush (stderr);
  94       return;
  95     }
  96 }
  97
  98
  99 SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
 100 SCM
 101 scm_errno (arg)
 102      SCM arg;
 103 {
 104   int old = errno;
 105   if (!SCM_UNBNDP (arg))
 106     {
 107       if (SCM_FALSEP (arg))
 108         errno = 0;
 109       else
 110         errno = SCM_INUM (arg);
 111     }
 112   return SCM_MAKINUM (old);
 113 }
 114
 115 SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror);
 116 SCM
 117 scm_perror (arg)
 118      SCM arg;
 119 {
 120   SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror);
 121   err_head (SCM_CHARS (arg));
 122   return SCM_UNSPECIFIED;
 123 }
 124
 125 void (*scm_error_callback) () = 0;
 126
 127 /* all errors thrown from C should pass through here.  */
 128 void
 129 scm_error (key, subr, message, args, rest)
 130      SCM key;
 131      char *subr;
 132      char *message;
 133      SCM args;
 134      SCM rest;
 135 {
 136   SCM arg_list;
 137   if (scm_error_callback)
 138     (*scm_error_callback) (key, subr, message, args, rest);
 139
 140   arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
 141                           message ? scm_makfrom0str (message) : SCM_BOOL_F,
 142                           args,
 143                           rest,
 144                           SCM_UNDEFINED);
 145   scm_ithrow (key, arg_list, 1);
 146
 147   /* No return, but just in case: */
 148
 149   write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
 150   exit (1);
 151 }
 152
 153 SCM_SYMBOL (scm_system_error_key, "system-error");
 154 void
 155 scm_syserror (subr)
 156      char *subr;
 157 {
 158   scm_error (scm_system_error_key,
 159              subr,
 160              "%s",
 161              scm_listify (scm_makfrom0str (strerror (errno)),
 162                           SCM_UNDEFINED),
 163              scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
 164 }
 165
 166 void
 167 scm_syserror_msg (subr, message, args)
 168      char *subr;
 169      char *message;
 170      SCM args;
 171 {
 172   scm_error (scm_system_error_key,
 173              subr,
 174              message,
 175              args,
 176              scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
 177 }
 178
 179 void
 180 scm_sysmissing (subr)
 181      char *subr;
 182 {
 183 #ifdef ENOSYS
 184   scm_error (scm_system_error_key,
 185              subr,
 186              "%s",
 187              scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
 188              scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
 189 #else
 190   scm_error (scm_system_error_key,
 191              subr,
 192              "Missing function",
 193              SCM_BOOL_F,
 194              scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
 195 #endif
 196 }
 197
 198 SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 199 void
 200 scm_num_overflow (subr)
 201   char *subr;
 202 {
 203   scm_error (scm_num_overflow_key,
 204              subr,
 205              "Numerical overflow",
 206              SCM_BOOL_F,
 207              SCM_BOOL_F);
 208 }
 209
 210 SCM_SYMBOL (scm_out_of_range_key, "out-of-range");
 211 void
 212 scm_out_of_range (subr, bad_value)
 213      char *subr;
 214      SCM bad_value;
 215 {
 216   scm_error (scm_out_of_range_key,
 217              subr,
 218              "Argument out of range: %S",
 219              scm_listify (bad_value, SCM_UNDEFINED),
 220              SCM_BOOL_F);
 221 }
 222
 223 SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 224 void
 225 scm_wrong_num_args (proc)
 226      SCM proc;
 227 {
 228   scm_error (scm_args_number_key,
 229              NULL,
 230              "Wrong number of arguments to %s",
 231              scm_listify (proc, SCM_UNDEFINED),
 232              SCM_BOOL_F);
 233 }
 234
 235 SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 236 void
 237 scm_wrong_type_arg (subr, pos, bad_value)
 238      char *subr;
 239      int pos;
 240      SCM bad_value;
 241 {
 242   scm_error (scm_arg_type_key,
 243              subr,
 244              (pos == 0) ? "Wrong type argument: %S"
 245              : "Wrong type argument in position %s: %S",
 246              (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
 247              : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
 248              SCM_BOOL_F);
 249 }
 250
 251 SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 252 void
 253 scm_memory_error (subr)
 254      char *subr;
 255 {
 256   scm_error (scm_memory_alloc_key,
 257              subr,
 258              "Memory allocation error",
 259              SCM_BOOL_F,
 260              SCM_BOOL_F);
 261 }
 262
 263 SCM_SYMBOL (scm_misc_error_key, "misc-error");
 264 void
 265 scm_misc_error (subr, message, args)
 266      char *subr;
 267      char *message;
 268      SCM args;
 269 {
 270   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 271 }
 272
 273 /* implements the SCM_ASSERT interface.  */
 274 SCM
 275 scm_wta (arg, pos, s_subr)
 276      SCM arg;
 277      char *pos;
 278      char *s_subr;
 279 {
 280   if (!s_subr || !*s_subr)
 281     s_subr = NULL;
 282   if ((~0x1fL) & (long) pos)
 283     {
 284       /* error string supplied.  */
 285       scm_misc_error (s_subr, pos, SCM_BOOL_F);
 286     }
 287   else
 288     {
 289       /* numerical error code.  */
 290       int error = (long) pos;
 291
 292       switch (error)
 293         {
 294         case SCM_ARGn:
 295           scm_wrong_type_arg (s_subr, 0, arg);
 296         case SCM_ARG1:
 297           scm_wrong_type_arg (s_subr, 1, arg);
 298         case SCM_ARG2:
 299           scm_wrong_type_arg (s_subr, 2, arg);
 300         case SCM_ARG3:
 301           scm_wrong_type_arg (s_subr, 3, arg);
 302         case SCM_ARG4:
 303           scm_wrong_type_arg (s_subr, 4, arg);
 304         case SCM_ARG5:
 305           scm_wrong_type_arg (s_subr, 5, arg);
 306         case SCM_WNA:
 307           scm_wrong_num_args (arg);
 308         case SCM_OUTOFRANGE:
 309           scm_out_of_range (s_subr, arg);
 310         case SCM_NALLOC:
 311           scm_memory_error (s_subr);
 312         default:
 313           /* this shouldn't happen.  */
 314           scm_misc_error (s_subr, "Unknown error", SCM_BOOL_F);
 315         }
 316     }
 317   return SCM_UNSPECIFIED;
 318 }
 319
 320 /*  obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
 321     was equivalent to scm_wta (arg, pos, s_subr)  */
 322
 323 void
 324 scm_init_error ()
 325 {
 326 #include "errnos.c"
 327 #include "error.x"
 328 }
 329