/[cmucl]/src/lisp/interr.c
ViewVC logotype

Contents of /src/lisp/interr.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Thu Jun 11 16:04:01 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, merged-unicode-utf16-extfmt-2009-06-11, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, portable-clx-import-2009-06-16, cross-sparc-branch-base, intl-branch-base, portable-clx-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.9: +40 -4 lines
File MIME type: text/plain
Merge Unicode work to trunk.  From label
unicode-utf16-extfmt-2009-06-11.
1 wlott 1.1 /*
2 rtoy 1.10 * $Header: /tiger/var/lib/cvsroots/cmucl/src/lisp/interr.c,v 1.10 2009/06/11 16:04:01 rtoy Rel $
3 wlott 1.1 *
4     * Stuff to handle internal errors.
5     *
6     */
7    
8     #include <stdio.h>
9     #include <stdarg.h>
10 rtoy 1.6 #include <stdlib.h>
11 wlott 1.1
12 ram 1.2 #include "arch.h"
13 wlott 1.1 #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 rtoy 1.8
21 wlott 1.1
22     /* Lossage handler. */
23    
24 rtoy 1.8 static void
25     default_lossage_handler(void)
26 wlott 1.1 {
27     exit(1);
28     }
29    
30 rtoy 1.8 static void (*lossage_handler) (void) = default_lossage_handler;
31 wlott 1.1
32 rtoy 1.8 void
33     set_lossage_handler(void handler(void))
34 wlott 1.1 {
35     lossage_handler = handler;
36     }
37    
38 rtoy 1.8 void
39     lose(char *fmt, ...)
40 wlott 1.1 {
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 rtoy 1.8
52 wlott 1.1
53     /* Internal error handler for when the Lisp error system doesn't exist. */
54    
55     static char *errors[] = ERRORS;
56    
57 rtoy 1.8 void
58     internal_error(os_context_t * context)
59 wlott 1.1 {
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 rtoy 1.8 } else if (scoffset == 254) {
73     scoffset = ptr[0] + ptr[1] * 256;
74 wlott 1.1 ptr += 2;
75     len -= 2;
76 rtoy 1.8 } else if (scoffset == 255) {
77     scoffset = ptr[0] + (ptr[1] << 8) + (ptr[2] << 16) + (ptr[3] << 24);
78 wlott 1.1 ptr += 4;
79     len -= 4;
80     }
81     sc = scoffset & 0x1f;
82     offset = scoffset >> 5;
83 rtoy 1.8
84 wlott 1.1 printf(" SC: %d, Offset: %d", sc, offset);
85     switch (sc) {
86     case sc_AnyReg:
87     case sc_DescriptorReg:
88 rtoy 1.8 putchar('\t');
89     brief_print(SC_REG(context, offset));
90     break;
91 wlott 1.1
92     case sc_BaseCharReg:
93 rtoy 1.8 ch = SC_REG(context, offset);
94 wlott 1.1 #ifdef i386
95 rtoy 1.8 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 wlott 1.1 case sc_SapReg:
121     #ifdef sc_WordPointerReg
122     case sc_WordPointerReg:
123     #endif
124 agoncharov 1.9 printf("\t0x%08lx\n", SC_REG(context, offset));
125 rtoy 1.8 break;
126 wlott 1.1 case sc_SignedReg:
127 agoncharov 1.9 printf("\t%ld\n", SC_REG(context, offset));
128 rtoy 1.8 break;
129 wlott 1.1 case sc_UnsignedReg:
130 agoncharov 1.9 printf("\t%lu\n", SC_REG(context, offset));
131 rtoy 1.8 break;
132     #if 0 /* broken */
133 dtc 1.4 #ifdef sc_SingleReg
134     case sc_SingleReg:
135 rtoy 1.8 printf("\t%g\n", *(float *) &context->sc_fpregs[offset]);
136     break;
137 wlott 1.1 #endif
138 dtc 1.4 #ifdef sc_DoubleReg
139     case sc_DoubleReg:
140 rtoy 1.8 printf("\t%g\n", *(double *) &context->sc_fpregs[offset]);
141     break;
142 dtc 1.4 #endif
143     #ifdef sc_LongReg
144     case sc_LongReg:
145 rtoy 1.8 printf("\t%Lg\n", *(long double *) &context->sc_fpregs[offset]);
146     break;
147 dtc 1.4 #endif
148 wlott 1.1 #endif
149     default:
150 rtoy 1.8 printf("\t???\n");
151     break;
152 wlott 1.1 }
153     }
154    
155     lose(NULL);
156     }
157 rtoy 1.8
158 wlott 1.1
159    
160    
161     /* Utility routines used by random pieces of code. */
162    
163 rtoy 1.8 lispobj
164 rtoy 1.10 debug_print(lispobj object)
165 wlott 1.1 {
166 rtoy 1.10
167     #ifndef UNICODE
168     printf("%s\n", (char *) (((struct vector *) PTR(object))->data));
169 pw 1.5 fflush(stdout);
170 rtoy 1.10 #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     int k;
178    
179     len = lisp_string->length >> 2;
180     lisp_chars = (unsigned short int*) lisp_string->data;
181    
182     for (k = 0; k < len; ++k) {
183     /*
184     * Do we really want to dump out 4 bytes? Should we
185     * just print out the low 8 bits of each Lisp
186     * character?
187     */
188     putw(*lisp_chars, stdout);
189     ++lisp_chars;
190     }
191     putchar('\n');
192    
193     fflush(stdout);
194     } else {
195     print(object);
196     }
197     } else {
198     #if 1
199     printf("obj @0x%lx: ", (unsigned long) object);
200     #endif
201     print(object);
202     }
203     #endif
204 wlott 1.1 return NIL;
205     }
206 rtoy 1.10

  ViewVC Help
Powered by ViewVC 1.1.5