libguile/error.c

   1 /*      Copyright (C) 1995,1996,1997 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, eno)
 168      char *subr;
 169      char *message;
 170      SCM args;
 171      int eno;
 172 {
 173   scm_error (scm_system_error_key,
 174              subr,
 175              message,
 176              args,
 177              scm_listify (SCM_MAKINUM (eno), SCM_UNDEFINED));
 178 }
 179
 180 void
 181 scm_sysmissing (subr)
 182      char *subr;
 183 {
 184 #ifdef ENOSYS
 185   scm_error (scm_system_error_key,
 186              subr,
 187              "%s",
 188              scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
 189              scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
 190 #else
 191   scm_error (scm_system_error_key,
 192              subr,
 193              "Missing function",
 194              SCM_BOOL_F,
 195              scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
 196 #endif
 197 }
 198
 199 SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow");
 200 void
 201 scm_num_overflow (subr)
 202   char *subr;
 203 {
 204   scm_error (scm_num_overflow_key,
 205              subr,
 206              "Numerical overflow",
 207              SCM_BOOL_F,
 208              SCM_BOOL_F);
 209 }
 210
 211 SCM_SYMBOL (scm_out_of_range_key, "out-of-range");
 212 void
 213 scm_out_of_range (subr, bad_value)
 214      char *subr;
 215      SCM bad_value;
 216 {
 217   scm_error (scm_out_of_range_key,
 218              subr,
 219              "Argument out of range: %S",
 220              scm_listify (bad_value, SCM_UNDEFINED),
 221              SCM_BOOL_F);
 222 }
 223
 224 SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args");
 225 void
 226 scm_wrong_num_args (proc)
 227      SCM proc;
 228 {
 229   scm_error (scm_args_number_key,
 230              NULL,
 231              "Wrong number of arguments to %s",
 232              scm_listify (proc, SCM_UNDEFINED),
 233              SCM_BOOL_F);
 234 }
 235
 236 SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg");
 237 void
 238 scm_wrong_type_arg (subr, pos, bad_value)
 239      char *subr;
 240      int pos;
 241      SCM bad_value;
 242 {
 243   scm_error (scm_arg_type_key,
 244              subr,
 245              (pos == 0) ? "Wrong type argument: %S"
 246              : "Wrong type argument in position %s: %S",
 247              (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
 248              : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
 249              SCM_BOOL_F);
 250 }
 251
 252 SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
 253 void
 254 scm_memory_error (subr)
 255      char *subr;
 256 {
 257   scm_error (scm_memory_alloc_key,
 258              subr,
 259              "Memory allocation error",
 260              SCM_BOOL_F,
 261              SCM_BOOL_F);
 262 }
 263
 264 SCM_SYMBOL (scm_misc_error_key, "misc-error");
 265 void
 266 scm_misc_error (subr, message, args)
 267      char *subr;
 268      char *message;
 269      SCM args;
 270 {
 271   scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
 272 }
 273
 274 /* implements the SCM_ASSERT interface.  */
 275 SCM
 276 scm_wta (arg, pos, s_subr)
 277      SCM arg;
 278      char *pos;
 279      char *s_subr;
 280 {
 281   if (!s_subr || !*s_subr)
 282     s_subr = NULL;
 283   if ((~0x1fL) & (long) pos)
 284     {
 285       /* error string supplied.  */
 286       scm_misc_error (s_subr, pos, SCM_BOOL_F);
 287     }
 288   else
 289     {
 290       /* numerical error code.  */
 291       int error = (long) pos;
 292
 293       switch (error)
 294         {
 295         case SCM_ARGn:
 296           scm_wrong_type_arg (s_subr, 0, arg);
 297         case SCM_ARG1:
 298           scm_wrong_type_arg (s_subr, 1, arg);
 299         case SCM_ARG2:
 300           scm_wrong_type_arg (s_subr, 2, arg);
 301         case SCM_ARG3:
 302           scm_wrong_type_arg (s_subr, 3, arg);
 303         case SCM_ARG4:
 304           scm_wrong_type_arg (s_subr, 4, arg);
 305         case SCM_ARG5:
 306           scm_wrong_type_arg (s_subr, 5, arg);
 307         case SCM_WNA:
 308           scm_wrong_num_args (arg);
 309         case SCM_OUTOFRANGE:
 310           scm_out_of_range (s_subr, arg);
 311         case SCM_NALLOC:
 312           scm_memory_error (s_subr);
 313         default:
 314           /* this shouldn't happen.  */
 315           scm_misc_error (s_subr, "Unknown error", SCM_BOOL_F);
 316         }
 317     }
 318   return SCM_UNSPECIFIED;
 319 }
 320
 321 /*  obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
 322     was equivalent to scm_wta (arg, pos, s_subr)  */
 323
 324 void
 325 scm_init_error ()
 326 {
 327 #include "errnos.c"
 328 #include "error.x"
 329 }
 330