Newer
Older
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.c,v 1.10 2009/06/11 16:04:01 rtoy Rel $
*
* Stuff to handle internal errors.
*
*/
#include <stdio.h>
#include <stdarg.h>
#include "signal.h"
#include "lisp.h"
#include "internals.h"
#include "interr.h"
#include "print.h"
#include "lispregs.h"
static void
default_lossage_handler(void)
static void (*lossage_handler) (void) = default_lossage_handler;
void
set_lossage_handler(void handler(void))
void
lose(char *fmt, ...)
{
va_list ap;
if (fmt != NULL) {
va_start(ap, fmt);
vfprintf(stderr, fmt, ap);
fflush(stderr);
va_end(ap);
}
lossage_handler();
}
/* Internal error handler for when the Lisp error system doesn't exist. */
static char *errors[] = ERRORS;
void
internal_error(os_context_t * context)
{
unsigned char *ptr = arch_internal_error_arguments(context);
int len, scoffset, sc, offset, ch;
len = *ptr++;
printf("Error: %s\n", errors[*ptr++]);
len--;
while (len > 0) {
scoffset = *ptr++;
len--;
if (scoffset == 253) {
scoffset = *ptr++;
len--;
} else if (scoffset == 254) {
scoffset = ptr[0] + ptr[1] * 256;
} else if (scoffset == 255) {
scoffset = ptr[0] + (ptr[1] << 8) + (ptr[2] << 16) + (ptr[3] << 24);
ptr += 4;
len -= 4;
}
sc = scoffset & 0x1f;
offset = scoffset >> 5;
printf(" SC: %d, Offset: %d", sc, offset);
switch (sc) {
case sc_AnyReg:
case sc_DescriptorReg:
putchar('\t');
brief_print(SC_REG(context, offset));
break;
ch = SC_REG(context, offset);
if (offset & 1)
ch = ch >> 8;
ch = ch & 0xff;
switch (ch) {
case '\n':
printf("\t'\\n'\n");
break;
case '\b':
printf("\t'\\b'\n");
break;
case '\t':
printf("\t'\\t'\n");
break;
case '\r':
printf("\t'\\r'\n");
break;
default:
if (ch < 32 || ch > 127)
printf("\\%03o", ch);
else
printf("\t'%c'\n", ch);
break;
}
break;
case sc_SapReg:
#ifdef sc_WordPointerReg
case sc_WordPointerReg:
#endif
printf("\t0x%08lx\n", SC_REG(context, offset));
printf("\t%ld\n", SC_REG(context, offset));
printf("\t%lu\n", SC_REG(context, offset));
break;
#if 0 /* broken */
#ifdef sc_SingleReg
case sc_SingleReg:
printf("\t%g\n", *(float *) &context->sc_fpregs[offset]);
break;
#ifdef sc_DoubleReg
case sc_DoubleReg:
printf("\t%g\n", *(double *) &context->sc_fpregs[offset]);
break;
#endif
#ifdef sc_LongReg
case sc_LongReg:
printf("\t%Lg\n", *(long double *) &context->sc_fpregs[offset]);
break;
printf("\t???\n");
break;
/* Utility routines used by random pieces of code. */
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
#if defined(UNICODE)
/*
* Convert a unicode code point to a set of utf8-encoded octets to
* standard output. This is the algorithm used by the Lisp utf8
* encoder in src/code/extfmts.lisp.
*/
static void
utf8(int code, int len)
{
int k;
int j = 6 - len;
int p = 6 * len;
int init = 0xff & (0x7e << j);
int c;
/*
* (ldb (byte j p) code): Extract j bits from position p of the code
*/
c = (code >> p) & ((1 << j) - 1);
putchar(init | c);
for (k = 0; k < len; ++k) {
p -= 6;
/* (ldb (byte 6 p) code) */
c = (code >> p) & ((1 << 6) - 1);
putchar(128 | c);
}
}
/*
* Test if code is a surrogate. Returns true if so. If the code is a
* surrogate, then type indicates if it is a high (0) or low (1)
* surrogate. If not a surrogate, type is not modified. If type is
* NULL, then no type is returned.
*/
boolean
surrogatep(int code, int *type)
{
boolean result;
if ((code >> 11) == 0x1b) {
result = 1;
if (type) {
*type = (code >> 10) & 1;
}
} else {
result = 0;
}
return result;
}
/*
* Convert one or two utf16 code units into a code point. utf16
* points to the string, len is the length of the string. The
* codepoint is returned and the number of code units consumed is
* returned in consumed.
*/
int
utf16_codepoint(unsigned short int* utf16, int len, int* consumed)
{
int code = *utf16;
int read = 1;
int code_type;
/*
* If the current code unit is not a surrogate, we're done.
* Otherwise process the surrogate
*/
if (surrogatep(code, &code_type)) {
/*
* Try to get the following surrogate, if there are still code
* units left. If not, we have a bare surrogate, so just
* return the replacement character.
*/
if (len > 0) {
int next = utf16[1];
int next_type;
if (surrogatep(next, &next_type)) {
/* Got the following surrogate, so combine them if possible */
if ((code_type == 0) && (next_type == 1)) {
/* High followed by low surrogate */
code = ((code - 0xd800) << 10) + next + 0x2400;
++read;
} else if ((code_type == 1) && (next_type == 0)) {
/* Low followed by high surrogate */
code = ((code - 0xd800) << 10) + next + 0x2400;;
++read;
} else {
/* Give up */
code = 0xfffd;
}
} else {
/* Surrogate followed by non-surrogate. Give up */
code = 0xfffd;
}
} else {
code = 0xfffd;
}
}
*consumed = read;
return code;
}
/*
* Send the utf-16 Lisp unicode string to standard output as a
* utf8-encoded sequence of octets.
*/
static void
utf16_output(unsigned short int* utf16, int len)
{
while (len) {
int consumed;
int code = utf16_codepoint(utf16, len, &consumed);
/* Output the codepoint */
if (code < 0x80) {
putchar(code);
} else if (code < 0x800) {
utf8(code, 1);
} else if (code < 0x10000) {
utf8(code, 2);
} else if (code < 0x110000) {
utf8(code, 3);
} else {
/*
* This shouldn't happen, but if it does we don't want to
* signal any kind of error so just output a question mark
* so we can continue.
*/
putchar('?');
}
len -= consumed;
utf16 += consumed;
}
}
#endif
/*
* debug_print is used by %primitive print to output a string.
*/
#ifndef UNICODE
printf("%s\n", (char *) (((struct vector *) PTR(object))->data));
#else
if (Pointerp(object)) {
struct vector *lisp_string = (struct vector*) PTR(object);
if ((unsigned long) lisp_string->header == type_SimpleString) {
unsigned short int* lisp_chars;
int len;
len = lisp_string->length >> 2;
lisp_chars = (unsigned short int*) lisp_string->data;
utf16_output(lisp_chars, len);
putchar('\n');
fflush(stdout);
} else {
print(object);
}
} else {
/*
* We should actually ever get here because %primitive print
* is only supposed to take strings. But if we do, it's
* useful to print something out anyway.
*/
#if 1
printf("obj @0x%lx: ", (unsigned long) object);
#endif
print(object);
}
#endif