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