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

Contents of /src/lisp/interr.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show 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 /*
2 * $Header: /tiger/var/lib/cvsroots/cmucl/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
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
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
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 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 return NIL;
205 }
206

  ViewVC Help
Powered by ViewVC 1.1.5