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