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
  69 err_head (str)
  70      char *str;
  71 {
  72   int oerrno = errno;
  73   if (SCM_NIMP (scm_cur_outp))
  74     scm_fflush (scm_cur_outp);
  75   scm_gen_putc ('\n', scm_cur_errp);
  76 #if 0
  77   if (SCM_BOOL_F != *scm_loc_loadpath)
  78     {
  79       scm_prin1 (*scm_loc_loadpath, scm_cur_errp, 1);
  80       scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp);
  81       scm_intprint ((long) scm_linum, 10, scm_cur_errp);
  82       scm_gen_puts (scm_regular_string, ": ", scm_cur_errp);
  83     }
  84 #endif
  85   scm_fflush (scm_cur_errp);
  86   errno = oerrno;
  87   if (scm_cur_errp == scm_def_errp)
  88     {
  89       if (errno > 0)
  90         perror (str);
  91       fflush (stderr);
  92       return;
  93     }
  94 }
  95
  96
  97 SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
  98 SCM
  99 scm_errno (arg)
 100      SCM arg;
 101 {
 102   int old = errno;
 103   if (!SCM_UNBNDP (arg))
 104     {
 105       if (SCM_FALSEP (arg))
 106         errno = 0;
 107       else
 108         errno = SCM_INUM (arg);
 109     }
 110   return SCM_MAKINUM (old);
 111 }
 112
 113 SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror);
 114 SCM
 115 scm_perror (arg)
 116      SCM arg;
 117 {
 118   SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror);
 119   err_head (SCM_CHARS (arg));
 120   return SCM_UNSPECIFIED;
 121 }
 122
 123 void (*scm_error_callback) () = 0;
 124
 125 /* all errors thrown from C should pass through here.  */
 126 /* also known as scm_error.  */
 127 void
 128 scm_error (key, subr, message, args, rest)
 129      SCM key;
 130      char *subr;
 131      char *message;
 132      SCM args;
 133      SCM rest;
 134 {
 135   SCM arg_list;
 136   if (scm_error_callback)
 137     (*scm_error_callback) (key, subr, message, args, rest);
 138
 139   arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
 140                           message ? scm_makfrom0str (message) : SCM_BOOL_F,
 141                           args,
 142                           rest,
 143                           SCM_UNDEFINED);
 144   scm_ithrow (key, arg_list, 1);
 145
 146   /* No return, but just in case: */
 147
 148   write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
 149   exit (1);
 150 }
 151
 152 /* error keys: defined here, initialized below, prototyped in error.h,
 153    associated with handler procedures in boot-9.scm.  */
 154 SCM scm_system_error_key;
 155 SCM scm_num_overflow_key;
 156 SCM scm_out_of_range_key;
 157 SCM scm_arg_type_key;
 158 SCM scm_args_number_key;
 159 SCM scm_memory_alloc_key;
 160 SCM scm_stack_overflow_key;
 161 SCM scm_misc_error_key;
 162
 163 void
 164 scm_syserror (subr)
 165      char *subr;
 166 {
 167   scm_error (scm_system_error_key,
 168              subr,
 169              "%s",
 170              scm_listify (scm_makfrom0str (strerror (errno)),
 171                           SCM_UNDEFINED),
 172              scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
 173 }
 174
 175 void
 176 scm_syserror_msg (subr, message, args)
 177      char *subr;
 178      char *message;
 179      SCM args;
 180 {
 181   scm_error (scm_system_error_key,
 182              subr,
 183              message,
 184              args,
 185              scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
 186 }
 187
 188 void
 189 scm_sysmissing (subr)
 190      char *subr;
 191 {
 192 #ifdef ENOSYS
 193   scm_error (scm_system_error_key,
 194              subr,
 195              "%s",
 196              scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
 197              scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
 198 #else
 199   scm_error (scm_system_error_key,
 200              subr,
 201              "Missing function",
 202              SCM_BOOL_F,
 203              scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
 204 #endif
 205 }
 206
 207 void
 208 scm_num_overflow (subr)
 209   char *subr;
 210 {
 211   scm_error (scm_num_overflow_key,
 212              subr,
 213              "Numerical overflow",
 214              SCM_BOOL_F,
 215              SCM_BOOL_F);
 216 }
 217
 218 void
 219 scm_out_of_range (subr, bad_value)
 220      char *subr;
 221      SCM bad_value;
 222 {
 223   scm_error (scm_out_of_range_key,
 224              subr,
 225              "Argument out of range: %S",
 226              scm_listify (bad_value, SCM_UNDEFINED),
 227              SCM_BOOL_F);
 228 }
 229
 230 void
 231 scm_wrong_num_args (proc)
 232      SCM proc;
 233 {
 234   scm_error (scm_args_number_key,
 235              NULL,
 236              "Wrong number of arguments to %s",
 237              scm_listify (proc, SCM_UNDEFINED),
 238              SCM_BOOL_F);
 239 }
 240
 241 void
 242 scm_wrong_type_arg (subr, pos, bad_value)
 243      char *subr;
 244      int pos;
 245      SCM bad_value;
 246 {
 247   scm_error (scm_arg_type_key,
 248              subr,
 249              (pos == 0) ? "Wrong type argument: %S"
 250              : "Wrong type argument in position %s: %S",
 251              (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
 252              : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
 253              SCM_BOOL_F);
 254 }
 255
 256 void
 257 scm_memory_error (subr)
 258      char *subr;
 259 {
 260   scm_error (scm_memory_alloc_key,
 261              subr,
 262              "Memory allocation error",
 263              SCM_BOOL_F,
 264              SCM_BOOL_F);
 265 }
 266
 267 /* implements the SCM_ASSERT interface.  */
 268 SCM
 269 scm_wta (arg, pos, s_subr)
 270      SCM arg;
 271      char *pos;
 272      char *s_subr;
 273 {
 274   if (!s_subr || !*s_subr)
 275     s_subr = NULL;
 276   if ((~0x1fL) & (long) pos)
 277     {
 278       /* error string supplied.  */
 279       scm_error (scm_misc_error_key,
 280                  s_subr,
 281                  pos,
 282                  SCM_BOOL_F,
 283                  SCM_BOOL_F);
 284     }
 285   else
 286     {
 287       /* numerical error code.  */
 288       int error = (long) pos;
 289
 290       switch (error)
 291         {
 292         case SCM_ARGn:
 293           scm_wrong_type_arg (s_subr, 0, arg);
 294         case SCM_ARG1:
 295           scm_wrong_type_arg (s_subr, 1, arg);
 296         case SCM_ARG2:
 297           scm_wrong_type_arg (s_subr, 2, arg);
 298         case SCM_ARG3:
 299           scm_wrong_type_arg (s_subr, 3, arg);
 300         case SCM_ARG4:
 301           scm_wrong_type_arg (s_subr, 4, arg);
 302         case SCM_ARG5:
 303           scm_wrong_type_arg (s_subr, 5, arg);
 304         case SCM_WNA:
 305           scm_wrong_num_args (arg);
 306         case SCM_OUTOFRANGE:
 307           scm_out_of_range (s_subr, arg);
 308         case SCM_NALLOC:
 309           scm_memory_error (s_subr);
 310         default:
 311           /* this shouldn't happen.  */
 312           scm_error (scm_misc_error_key,
 313                      s_subr,
 314                      "Unknown error",
 315                      SCM_BOOL_F,
 316                      SCM_BOOL_F);
 317         }
 318     }
 319   return SCM_UNSPECIFIED;
 320 }
 321
 322 /*  obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
 323     was equivalent to scm_wta (arg, pos, s_subr)  */
 324
 325 void
 326 scm_init_error ()
 327 {
 328   scm_system_error_key
 329     = scm_permanent_object (SCM_CAR (scm_intern0 ("system-error")));
 330   scm_num_overflow_key
 331     = scm_permanent_object (SCM_CAR (scm_intern0 ("numerical-overflow")));
 332   scm_out_of_range_key
 333     = scm_permanent_object (SCM_CAR (scm_intern0 ("out-of-range")));
 334   scm_arg_type_key
 335     = scm_permanent_object (SCM_CAR (scm_intern0 ("wrong-type-arg")));
 336   scm_args_number_key
 337     = scm_permanent_object (SCM_CAR (scm_intern0 ("wrong-number-of-args")));
 338   scm_memory_alloc_key
 339     = scm_permanent_object (SCM_CAR (scm_intern0 ("memory-allocation-error")));
 340   scm_stack_overflow_key
 341     = scm_permanent_object (SCM_CAR (scm_intern0 ("stack-overflow")));
 342   scm_misc_error_key
 343     = scm_permanent_object (SCM_CAR (scm_intern0 ("misc-error")));
 344 #include "error.x"
 345 }
 346