f5bc61faaa3743d04c6b1bfdafea8f7fda2e24f8
[projects/cmucl/cmucl.git] / src / lisp / interr.c
1 /*
2  * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.c,v 1.10 2009/06/11 16:04:01 rtoy Rel $
3  *
4  * Stuff to handle internal errors.
5  *
6  */
7
8 #include <stdio.h>
9 #include <stdarg.h>
10 #include <stdlib.h>
11
12 #include "arch.h"
13 #include "signal.h"
14
15 #include "lisp.h"
16 #include "internals.h"
17 #include "interr.h"
18 #include "print.h"
19 #include "lispregs.h"
20 \f
21
22 /* Lossage handler. */
23
24 static void
25 default_lossage_handler(void)
26 {
27     exit(1);
28 }
29
30 static void (*lossage_handler) (void) = default_lossage_handler;
31
32 void
33 set_lossage_handler(void handler(void))
34 {
35     lossage_handler = handler;
36 }
37
38 void
39 lose(char *fmt, ...)
40 {
41     va_list ap;
42
43     if (fmt != NULL) {
44         va_start(ap, fmt);
45         vfprintf(stderr, fmt, ap);
46         fflush(stderr);
47         va_end(ap);
48     }
49     lossage_handler();
50 }
51 \f
52
53 /* Internal error handler for when the Lisp error system doesn't exist. */
54
55 static char *errors[] = ERRORS;
56
57 void
58 internal_error(os_context_t * context)
59 {
60     unsigned char *ptr = arch_internal_error_arguments(context);
61     int len, scoffset, sc, offset, ch;
62
63     len = *ptr++;
64     printf("Error: %s\n", errors[*ptr++]);
65     len--;
66     while (len > 0) {
67         scoffset = *ptr++;
68         len--;
69         if (scoffset == 253) {
70             scoffset = *ptr++;
71             len--;
72         } else if (scoffset == 254) {
73             scoffset = ptr[0] + ptr[1] * 256;
74             ptr += 2;
75             len -= 2;
76         } else if (scoffset == 255) {
77             scoffset = ptr[0] + (ptr[1] << 8) + (ptr[2] << 16) + (ptr[3] << 24);
78             ptr += 4;
79             len -= 4;
80         }
81         sc = scoffset & 0x1f;
82         offset = scoffset >> 5;
83
84         printf("    SC: %d, Offset: %d", sc, offset);
85         switch (sc) {
86           case sc_AnyReg:
87           case sc_DescriptorReg:
88               putchar('\t');
89               brief_print(SC_REG(context, offset));
90               break;
91
92           case sc_BaseCharReg:
93               ch = SC_REG(context, offset);
94 #ifdef i386
95               if (offset & 1)
96                   ch = ch >> 8;
97               ch = ch & 0xff;
98 #endif
99               switch (ch) {
100                 case '\n':
101                     printf("\t'\\n'\n");
102                     break;
103                 case '\b':
104                     printf("\t'\\b'\n");
105                     break;
106                 case '\t':
107                     printf("\t'\\t'\n");
108                     break;
109                 case '\r':
110                     printf("\t'\\r'\n");
111                     break;
112                 default:
113                     if (ch < 32 || ch > 127)
114                         printf("\\%03o", ch);
115                     else
116                         printf("\t'%c'\n", ch);
117                     break;
118               }
119               break;
120           case sc_SapReg:
121 #ifdef sc_WordPointerReg
122           case sc_WordPointerReg:
123 #endif
124               printf("\t0x%08lx\n", SC_REG(context, offset));
125               break;
126           case sc_SignedReg:
127               printf("\t%ld\n", SC_REG(context, offset));
128               break;
129           case sc_UnsignedReg:
130               printf("\t%lu\n", SC_REG(context, offset));
131               break;
132 #if 0                           /* broken */
133 #ifdef sc_SingleReg
134           case sc_SingleReg:
135               printf("\t%g\n", *(float *) &context->sc_fpregs[offset]);
136               break;
137 #endif
138 #ifdef sc_DoubleReg
139           case sc_DoubleReg:
140               printf("\t%g\n", *(double *) &context->sc_fpregs[offset]);
141               break;
142 #endif
143 #ifdef sc_LongReg
144           case sc_LongReg:
145               printf("\t%Lg\n", *(long double *) &context->sc_fpregs[offset]);
146               break;
147 #endif
148 #endif
149           default:
150               printf("\t???\n");
151               break;
152         }
153     }
154
155     lose(NULL);
156 }
157 \f
158
159
160
161 /* Utility routines used by random pieces of code. */
162
163 #if defined(UNICODE)
164
165 /* The Unicode replacement character code */
166 #define REPLACEMENT_CODE 0xfffd
167
168 /*
169  * Convert a unicode code point to a set of utf8-encoded octets to
170  * standard output.  This is the algorithm used by the Lisp utf8
171  * encoder in src/code/extfmts.lisp.
172  */
173 static void
174 utf8(int code, int len)
175 {
176     int k;
177     int j = 6 - len;
178     int p = 6 * len;
179     int init = 0xff & (0x7e << j);
180     int c;
181
182     /*
183      * (ldb (byte j p) code): Extract j bits from position p of the code
184      */
185     c = (code >> p) & ((1 << j) - 1);
186     
187     putchar(init | c);
188
189     for (k = 0; k < len; ++k) {
190         p -= 6;
191         /* (ldb (byte 6 p) code) */
192         c = (code >> p) & ((1 << 6) - 1);
193         putchar(128 | c);
194     }
195 }
196
197 /*
198  * Test if code is a surrogate.  Returns true if so. If the code is a
199  * surrogate, then type indicates if it is a high (0) or low (1)
200  * surrogate.  If not a surrogate, type is not modified.  If type is
201  * NULL, then no type is returned.
202  */
203 static boolean
204 surrogatep(int code, int *type)
205 {
206     boolean result;
207
208     if ((code >> 11) == 0x1b) {
209         result = 1;
210         if (type) {
211             *type = (code >> 10) & 1;
212         }
213     } else {
214         result = 0;
215     }
216
217     return result;
218 }
219
220 /*
221  * Convert one or two utf16 code units into a code point.  utf16
222  * points to the string, len is the length of the string.  The
223  * codepoint is returned and the number of code units consumed is
224  * returned in consumed.
225  */
226 static int
227 utf16_codepoint(unsigned short int* utf16, int len, int* consumed)
228 {
229     int code = *utf16;
230     int read = 1;
231     
232     int code_type;
233
234     /*
235      * If the current code unit is not a surrogate, we're done.
236      * Otherwise process the surrogate.
237      */
238     
239     if (surrogatep(code, &code_type)) {
240         /*
241          * Try to get the following surrogate, if there are still code
242          * units left.  If not, we have a bare surrogate, so just
243          * return the replacement character.
244          */
245         if (len > 0) {
246             int next = utf16[1];
247             int next_type;
248             if (surrogatep(next, &next_type)) {
249                 /* Got the following surrogate, so combine them if possible */
250                 if ((code_type == 0) && (next_type == 1)) {
251                     /* High followed by low surrogate */
252                     code = ((code - 0xd800) << 10) + next + 0x2400;
253                     ++read;
254                 } else if ((code_type == 1) && (next_type == 0)) {
255                     /*
256                      * Low followed by high surrogate.  Not sure if we
257                      * really need to handle this case.
258                      */
259                     code = ((code - 0xd800) << 10) + next + 0x2400;;
260                     ++read;
261                 } else {
262                     /* Give up */
263                     code = REPLACEMENT_CODE;
264                 }
265             } else {
266                 /* Surrogate followed by non-surrogate. Give up */
267                 code = REPLACEMENT_CODE;
268             }
269         } else {
270             code = REPLACEMENT_CODE;
271         }
272     }
273
274     *consumed = read;
275     return code;
276 }
277
278 /*
279  * Send the utf-16 Lisp unicode string to standard output as a
280  * utf8-encoded sequence of octets.
281  */
282 static void
283 utf16_output(unsigned short int* utf16, int len)
284 {
285     while (len) {
286         int consumed;
287         int code = utf16_codepoint(utf16, len, &consumed);
288
289         /* Output the codepoint */
290         if (code < 0x80) {
291             putchar(code);
292         } else if (code < 0x800) {
293             utf8(code, 1);
294         } else if (code < 0x10000) {
295             utf8(code, 2);
296         } else if (code < 0x110000) {
297             utf8(code, 3);
298         } else {
299             /*
300              * This shouldn't happen, but if it does we don't want to
301              * signal any kind of error so just output a question mark
302              * so we can continue.
303              */
304             putchar('?');
305         }
306
307         len -= consumed;
308         utf16 += consumed;
309     }
310 }
311 #endif
312
313 /*
314  * debug_print is used by %primitive print to output a string.
315  */
316 lispobj
317 debug_print(lispobj object)
318 {
319     
320 #ifndef UNICODE
321     printf("%s\n", (char *) (((struct vector *) PTR(object))->data));
322     fflush(stdout);
323 #else    
324     if (Pointerp(object)) {
325         struct vector *lisp_string = (struct vector*) PTR(object);
326         
327         if ((unsigned long) lisp_string->header == type_SimpleString) {
328             unsigned short int* lisp_chars;
329             int len;
330
331             len = lisp_string->length >> 2;
332             lisp_chars = (unsigned short int*) lisp_string->data;
333
334             utf16_output(lisp_chars, len);
335             putchar('\n');
336     
337             fflush(stdout);
338         } else {
339             print(object);
340         }
341     } else {
342         /*
343          * We should actually ever get here because %primitive print
344          * is only supposed to take strings.  But if we do, it's
345          * useful to print something out anyway.
346          */
347 #if 1
348         printf("obj @0x%lx: ", (unsigned long) object);
349 #endif
350         print(object);
351     }
352 #endif            
353     return NIL;
354 }
355