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 static 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