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 lispobj
 164 debug_print(lispobj object)
 165 {
 166
 167 #ifndef UNICODE
 168     printf("%s\n", (char *) (((struct vector *) PTR(object))->data));
 169     fflush(stdout);
 170 #else
 171     if (Pointerp(object)) {
 172         struct vector *lisp_string = (struct vector*) PTR(object);
 173
 174         if ((unsigned long) lisp_string->header == type_SimpleString) {
 175             unsigned short int* lisp_chars;
 176             int len;
 177
 178             len = lisp_string->length >> 2;
 179             lisp_chars = (unsigned short int*) lisp_string->data;
 180
 181             /*
 182              * Do we really want to dump out the entire contents of
 183              * the utf-16 string?  Should we just print out the low 8
 184              * bits of each Lisp character?  Or maybe convert the
 185              * utf-16 string to some more suitable encoding?
 186              */
 187             fwrite(lisp_chars, sizeof(*lisp_chars), len, stdout);
 188             putchar('\n');
 189
 190             fflush(stdout);
 191         } else {
 192             print(object);
 193         }
 194     } else {
 195 #if 1
 196         printf("obj @0x%lx: ", (unsigned long) object);
 197 #endif
 198         print(object);
 199     }
 200 #endif
 201     return NIL;
 202 }
 203