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
  46 \f
  47
  48 \f
  49 /* {Errors and Exceptional Conditions}
  50  */
  51
  52 SCM system_error_sym;
  53
  54 /* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
  55  * when the interpreter is not running at all.
  56  */
  57 int scm_ints_disabled = 1;
  58
  59
  60 extern int errno;
  61 #ifdef __STDC__
  62 static void
  63 err_head (char *str)
  64 #else
  65 static void
  66 err_head (str)
  67      char *str;
  68 #endif
  69 {
  70   int oerrno = errno;
  71   if (SCM_NIMP (scm_cur_outp))
  72     scm_fflush (scm_cur_outp);
  73   scm_gen_putc ('\n', scm_cur_errp);
  74 #if 0
  75   if (SCM_BOOL_F != *scm_loc_loadpath)
  76     {
  77       scm_iprin1 (*scm_loc_loadpath, scm_cur_errp, 1);
  78       scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp);
  79       scm_intprint ((long) scm_linum, 10, scm_cur_errp);
  80       scm_gen_puts (scm_regular_string, ": ", scm_cur_errp);
  81     }
  82 #endif
  83   scm_fflush (scm_cur_errp);
  84   errno = oerrno;
  85   if (scm_cur_errp == scm_def_errp)
  86     {
  87       if (errno > 0)
  88         perror (str);
  89       fflush (stderr);
  90       return;
  91     }
  92 }
  93
  94
  95 SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
  96 #ifdef __STDC__
  97 SCM
  98 scm_errno (SCM arg)
  99 #else
 100 SCM
 101 scm_errno (arg)
 102      SCM arg;
 103 #endif
 104 {
 105   int old = errno;
 106   if (!SCM_UNBNDP (arg))
 107     {
 108       if (SCM_FALSEP (arg))
 109         errno = 0;
 110       else
 111         errno = SCM_INUM (arg);
 112     }
 113   return SCM_MAKINUM (old);
 114 }
 115
 116 SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror);
 117 #ifdef __STDC__
 118 SCM
 119 scm_perror (SCM arg)
 120 #else
 121 SCM
 122 scm_perror (arg)
 123      SCM arg;
 124 #endif
 125 {
 126   SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror);
 127   err_head (SCM_CHARS (arg));
 128   return SCM_UNSPECIFIED;
 129 }
 130
 131
 132 #ifdef __STDC__
 133 void
 134 scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr)
 135 #else
 136 void
 137 scm_everr (exp, env, arg, pos, s_subr)
 138      SCM exp;
 139      SCM env;
 140      SCM arg;
 141      char *pos;
 142      char *s_subr;
 143 #endif
 144 {
 145   SCM desc;
 146   SCM args;
 147
 148   if ((~0x1fL) & (long) pos)
 149     desc = scm_makfrom0str (pos);
 150   else
 151     desc = SCM_MAKINUM ((long)pos);
 152
 153   {
 154     SCM sym;
 155     if (!s_subr || !*s_subr)
 156       sym = SCM_BOOL_F;
 157     else
 158       sym = SCM_CAR (scm_intern0 (s_subr));
 159     args = scm_listify (desc, sym, arg, SCM_UNDEFINED);
 160   }
 161
 162   /* (throw (quote %%system-error) <desc> <proc-name> arg)
 163    *
 164    * <desc> is a string or an integer (see %%system-errors).
 165    * <proc-name> is a symbol or #f in some annoying cases (e.g. cddr).
 166    */
 167
 168   scm_ithrow (system_error_sym, args, 1);
 169
 170   /* No return, but just in case: */
 171
 172   write (2, "unhandled system error", sizeof ("unhandled system error"));
 173   exit (1);
 174 }
 175
 176 #ifdef __STDC__
 177 SCM
 178 scm_wta (SCM arg, char *pos, char *s_subr)
 179 #else
 180 SCM
 181 scm_wta (arg, pos, s_subr)
 182      SCM arg;
 183      char *pos;
 184      char *s_subr;
 185 #endif
 186 {
 187   scm_everr (SCM_UNDEFINED, SCM_EOL, arg, pos, s_subr);
 188   return SCM_UNSPECIFIED;
 189 }
 190
 191
 192
 193 #ifdef __STDC__
 194 void
 195 scm_init_error (void)
 196 #else
 197 void
 198 scm_init_error ()
 199 #endif
 200 {
 201   system_error_sym = SCM_CAR (scm_intern0 ("%%system-error"));
 202   scm_permanent_object (system_error_sym);
 203 #include "error.x"
 204 }
 205