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