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

Contents of /src/lisp/print.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Fri Oct 22 04:07:33 2010 UTC (3 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, 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, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, cross-sol-x86-branch
Changes since 1.29: +2 -1 lines
File MIME type: text/plain
Oops.  Need to include stdint.h to get uint16_t defined.
1 /* $Header: /tiger/var/lib/cvsroots/cmucl/src/lisp/print.c,v 1.30 2010/10/22 04:07:33 rtoy Exp $ */
2
3 #include <stdio.h>
4 #include <string.h>
5 #include <stdint.h>
6 #include "print.h"
7 #include "lisp.h"
8 #include "internals.h"
9 #include "monitor.h"
10 #include "vars.h"
11 #include "os.h"
12
13 static int max_lines = 20, cur_lines = 0;
14 static int max_depth = 5, brief_depth = 2, cur_depth = 0;
15 static int max_length = 5;
16 static boolean dont_decend = FALSE, skip_newline = FALSE;
17 static int cur_clock = 0;
18
19 static void print_obj(char *prefix, lispobj obj);
20
21 #define NEWLINE if (continue_p(TRUE)) newline(NULL); else return;
22
23 char *lowtag_Names[] = {
24 "even fixnum",
25 "function pointer",
26 "other immediate [0]",
27 "list pointer",
28 "odd fixnum",
29 "instance pointer",
30 "other immediate [1]",
31 "other pointer"
32 };
33
34 char *subtype_Names[] = {
35 "unused 0",
36 "unused 1",
37 "bignum",
38 "ratio",
39 "single float",
40 "double float",
41 #ifdef type_LongFloat
42 "long float",
43 #endif
44 #ifdef type_DoubleDoubleFloat
45 "double-double float",
46 #endif
47 "complex",
48 #ifdef type_ComplexSingleFloat
49 "complex single float",
50 #endif
51 #ifdef type_ComplexDoubleFloat
52 "complex double float",
53 #endif
54 #ifdef type_ComplexLongFloat
55 "complex long float",
56 #endif
57 #ifdef type_ComplexDoubleDoubleFloat
58 "complex double-double float",
59 #endif
60 "simple-array",
61 "simple-string",
62 "simple-bit-vector",
63 "simple-vector",
64 "(simple-array (unsigned-byte 2) (*))",
65 "(simple-array (unsigned-byte 4) (*))",
66 "(simple-array (unsigned-byte 8) (*))",
67 "(simple-array (unsigned-byte 16) (*))",
68 "(simple-array (unsigned-byte 32) (*))",
69 #ifdef type_SimpleArraySignedByte8
70 "(simple-array (signed-byte 8) (*))",
71 #endif
72 #ifdef type_SimpleArraySignedByte16
73 "(simple-array (signed-byte 16) (*))",
74 #endif
75 #ifdef type_SimpleArraySignedByte30
76 "(simple-array fixnum (*))",
77 #endif
78 #ifdef type_SimpleArraySignedByte32
79 "(simple-array (signed-byte 32) (*))",
80 #endif
81 "(simple-array single-float (*))",
82 "(simple-array double-float (*))",
83 #ifdef type_SimpleArrayLongFloat
84 "(simple-array long-float (*))",
85 #endif
86 #ifdef type_SimpleArrayDoubleDoubleFloat
87 "(simple-array double-double-float (*))",
88 #endif
89 #ifdef type_SimpleArrayComplexSingleFloat
90 "(simple-array (complex single-float) (*))",
91 #endif
92 #ifdef type_SimpleArrayComplexDoubleFloat
93 "(simple-array (complex double-float) (*))",
94 #endif
95 #ifdef type_SimpleArrayComplexLongFloat
96 "(simple-array (complex long-float) (*))",
97 #endif
98 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
99 "(simple-array (complex double-double-float) (*))",
100 #endif
101 "complex-string",
102 "complex-bit-vector",
103 "(array * (*))",
104 "array",
105 "code header",
106 "function header",
107 "closure header",
108 "funcallable-instance header",
109 "byte code function",
110 "byte code closure",
111 /* "unused function header 3",*/
112 "closure function header",
113 "return PC header",
114 "value cell header",
115 "symbol header",
116 "character",
117 "SAP",
118 "unbound marker",
119 "weak pointer",
120 "instance header",
121 "fdefn"
122 #ifdef type_ScavengerHook
123 , "scavenger hook"
124 #endif
125 };
126
127 static void
128 indent(int in)
129 {
130 static char *spaces =
131
132 " ";
133
134 while (in > 64) {
135 fputs(spaces, stdout);
136 in -= 64;
137 }
138 if (in != 0)
139 fputs(spaces + 64 - in, stdout);
140 }
141
142 static boolean
143 continue_p(boolean newline)
144 {
145 char buffer[256];
146
147 if (cur_depth >= max_depth || dont_decend)
148 return FALSE;
149
150 if (newline) {
151 if (skip_newline)
152 skip_newline = FALSE;
153 else
154 putchar('\n');
155
156 if (cur_lines >= max_lines) {
157 printf("More? [y] ");
158 fflush(stdout);
159
160 fgets(buffer, sizeof(buffer), stdin);
161
162 if (buffer[0] == 'n' || buffer[0] == 'N')
163 throw_to_monitor();
164 else
165 cur_lines = 0;
166 }
167 }
168
169 return TRUE;
170 }
171
172 static void
173 newline(char *label)
174 {
175 cur_lines++;
176 if (label != NULL)
177 fputs(label, stdout);
178 putchar('\t');
179 indent(cur_depth * 2);
180 }
181
182
183 static void
184 brief_fixnum(lispobj obj)
185 {
186 #ifndef alpha
187 printf("%ld", ((long) obj) >> 2);
188 #else
189 printf("%d", ((s32) obj) >> 2);
190 #endif
191 }
192
193 static void
194 print_fixnum(lispobj obj)
195 {
196 #ifndef alpha
197 printf(": %ld", ((long) obj) >> 2);
198 #else
199 printf(": %d", ((s32) obj) >> 2);
200 #endif
201 }
202
203 static void
204 brief_otherimm(lispobj obj)
205 {
206 int type, c, idx;
207 char buffer[10];
208
209 type = TypeOf(obj);
210 switch (type) {
211 case type_BaseChar:
212 c = (obj >> 8) & 0xff;
213 switch (c) {
214 case '\0':
215 printf("#\\Null");
216 break;
217 case '\n':
218 printf("#\\Newline");
219 break;
220 case '\b':
221 printf("#\\Backspace");
222 break;
223 case '\177':
224 printf("#\\Delete");
225 break;
226 default:
227 strcpy(buffer, "#\\");
228 if (c >= 128) {
229 strcat(buffer, "m-");
230 c -= 128;
231 }
232 if (c < 32) {
233 strcat(buffer, "c-");
234 c += '@';
235 }
236 printf("%s%c", buffer, c);
237 break;
238 }
239 break;
240
241 case type_UnboundMarker:
242 printf("<unbound marker>");
243 break;
244
245 default:
246 idx = type >> 2;
247 if (idx < (sizeof(subtype_Names) / sizeof(char *)))
248 printf("%s", subtype_Names[idx]);
249
250 else
251 printf("unknown type (0x%0x)", type);
252 break;
253 }
254 }
255
256 static void
257 print_otherimm(lispobj obj)
258 {
259 int type, idx;
260
261 type = TypeOf(obj);
262 idx = type >> 2;
263
264 if (idx < (sizeof(subtype_Names) / sizeof(char *)))
265 printf(", %s", subtype_Names[idx]);
266
267 else
268 printf(", unknown type (0x%0x)", type);
269
270 switch (TypeOf(obj)) {
271 case type_BaseChar:
272 printf(": ");
273 brief_otherimm(obj);
274 break;
275
276 case type_Sap:
277 case type_UnboundMarker:
278 break;
279
280 default:
281 printf(": data=%ld", (obj >> 8) & 0xffffff);
282 break;
283 }
284 }
285
286 static void
287 brief_list(lispobj obj)
288 {
289 int space = FALSE;
290 int length = 0;
291
292 if (!valid_addr((os_vm_address_t) obj))
293 printf("(invalid address)");
294 else if (obj == NIL)
295 printf("NIL");
296 else {
297 putchar('(');
298 while (LowtagOf(obj) == type_ListPointer) {
299 struct cons *cons = (struct cons *) PTR(obj);
300
301 if (space)
302 putchar(' ');
303 if (++length >= max_length) {
304 printf("...");
305 obj = NIL;
306 break;
307 }
308 print_obj(NULL, cons->car);
309 obj = cons->cdr;
310 space = TRUE;
311 if (obj == NIL)
312 break;
313 }
314 if (obj != NIL) {
315 printf(" . ");
316 print_obj(NULL, obj);
317 }
318 putchar(')');
319 }
320 }
321
322 static void
323 print_list(lispobj obj)
324 {
325 if (!valid_addr((os_vm_address_t) obj))
326 printf("(invalid address)");
327 else if (obj == NIL)
328 printf(" (NIL)");
329 else {
330 struct cons *cons = (struct cons *) PTR(obj);
331
332 print_obj("car: ", cons->car);
333 print_obj("cdr: ", cons->cdr);
334 }
335 }
336
337 static void
338 brief_struct(lispobj obj)
339 {
340 printf("#<ptr to 0x%08lx instance>",
341 ((struct instance *) PTR(obj))->slots[0]);
342 }
343
344 static void
345 print_struct(lispobj obj)
346 {
347 struct instance *instance = (struct instance *) PTR(obj);
348 int i;
349 char buffer[16];
350
351 print_obj("type: ", ((struct instance *) PTR(obj))->slots[0]);
352 for (i = 1; i < HeaderValue(instance->header); i++) {
353 sprintf(buffer, "slot %d: ", i);
354 print_obj(buffer, instance->slots[i]);
355 }
356 }
357
358 static void
359 print_string(struct vector* vector)
360 {
361 #ifndef UNICODE
362 char *charptr;
363
364 for (charptr = (char *) vector->data; *charptr != '\0'; charptr++) {
365 if (*charptr == '"')
366 putchar('\\');
367 putchar(*charptr);
368 }
369 #else
370 uint16_t *charptr = (uint16_t *) vector->data;
371 int len = fixnum_value(vector->length);
372
373 while (len-- > 0) {
374 if ((*charptr == '"')) {
375 putchar('\\');
376 }
377 /* Just dump out the UTF-16 data */
378 putw(*charptr, stdout);
379 charptr++;
380 }
381 #endif
382 }
383
384 static void
385 brief_otherptr(lispobj obj)
386 {
387 lispobj *ptr, header;
388 int type;
389 struct symbol *symbol;
390 struct vector *vector;
391
392 ptr = (lispobj *) PTR(obj);
393
394 if (!valid_addr((os_vm_address_t) obj)) {
395 printf("(invalid address)");
396 return;
397 }
398
399 header = *ptr;
400 type = TypeOf(header);
401 switch (type) {
402 case type_SymbolHeader:
403 symbol = (struct symbol *) ptr;
404 vector = (struct vector *) PTR(symbol->name);
405 print_string(vector);
406 break;
407
408 case type_SimpleString:
409 vector = (struct vector *) ptr;
410 putchar('"');
411 print_string(vector);
412 putchar('"');
413 break;
414
415 default:
416 printf("#<ptr to ");
417 brief_otherimm(header);
418 putchar('>');
419 }
420 }
421
422 static void
423 print_slots(char **slots, int count, lispobj * ptr)
424 {
425 while (count-- > 0)
426 if (*slots)
427 print_obj(*slots++, *ptr++);
428 else
429 print_obj("???: ", *ptr++);
430 }
431
432 static char *symbol_slots[] = { "value: ", "hash: ",
433 "plist: ", "name: ", "package: ", NULL
434 };
435 static char *ratio_slots[] = { "numer: ", "denom: ", NULL };
436 static char *complex_slots[] = { "real: ", "imag: ", NULL };
437 static char *code_slots[] = { "words: ", "entry: ", "debug: ", NULL };
438 static char *array_slots[] = { "fill-pointer: ",
439 "fill-pointer-p: ",
440 "elements: ",
441 "data: ",
442 "displacement: ",
443 "displaced-p: ",
444 /* Some reasonable number of dimensions */
445 "dimension 1: ",
446 "dimension 2: ",
447 "dimension 3: ",
448 "dimension 4: ",
449 "dimension 5: ",
450 "dimension 6: ",
451 "dimension 7: ",
452 NULL
453 };
454
455 static char *simple_array_slots[] = { "length: ",
456 NULL
457 };
458
459 #if (defined(i386) || defined(__x86_64))
460 static char *fn_slots[] =
461 { "inst start: ", "next: ", "name: ", "arglist: ", "type: ", NULL };
462 #else
463 static char *fn_slots[] =
464 { "self: ", "next: ", "name: ", "arglist: ", "type: ", NULL };
465 #endif
466
467 static char *closure_slots[] = { "fn: ", NULL };
468 static char *funcallable_instance_slots[] =
469 { "fn: ", "lexenv: ", "layout: ", NULL };
470 static char *weak_pointer_slots[] = { "value: ", "broken: ",
471 #ifdef GENCGC
472 "mark-bit: ",
473 #endif
474 NULL
475 };
476 static char *fdefn_slots[] = { "name: ", "function: ", "raw_addr: ", NULL };
477 static char *value_cell_slots[] = { "value: ", NULL };
478
479 #ifdef type_ScavengerHook
480 static char *scavenger_hook_slots[] =
481
482 { "value: ", "function: ", "next: ", NULL };
483 #endif
484
485 static void
486 print_otherptr(lispobj obj)
487 {
488 if (!valid_addr((os_vm_address_t) obj))
489 printf("(invalid address)");
490 else {
491 #ifndef alpha
492 unsigned long *ptr;
493 unsigned long header;
494 unsigned long length;
495 #else
496 u32 *ptr;
497 u32 header;
498 u32 length;
499 #endif
500 int count, type, index;
501 char buffer[16];
502
503 #ifndef alpha
504 ptr = (unsigned long *) PTR(obj);
505 if (ptr == (unsigned long *) NULL) {
506 #else
507 ptr = (u32 *) PTR(obj);
508 if (ptr == (u32 *) NULL) {
509 #endif
510 printf(" (NULL Pointer)");
511 return;
512 }
513
514 header = *ptr++;
515 length = fixnum_value(*ptr);
516 count = header >> 8;
517 type = TypeOf(header);
518
519 print_obj("header: ", header);
520 if (LowtagOf(header) != type_OtherImmediate0
521 && LowtagOf(header) != type_OtherImmediate1) {
522 NEWLINE;
523 printf("(invalid header object)");
524 return;
525 }
526
527 switch (type) {
528 case type_Bignum:
529 ptr += count;
530 NEWLINE;
531 printf("0x");
532 while (count-- > 0)
533 printf("%08lx", *--ptr);
534 break;
535
536 case type_Ratio:
537 print_slots(ratio_slots, count, ptr);
538 break;
539
540 case type_Complex:
541 print_slots(complex_slots, count, ptr);
542 break;
543
544 case type_SymbolHeader:
545 print_slots(symbol_slots, count, ptr);
546 break;
547
548 case type_SingleFloat:
549 NEWLINE;
550 printf("%g", ((struct single_float *) PTR(obj))->value);
551 break;
552
553 case type_DoubleFloat:
554 NEWLINE;
555 printf("%g", ((struct double_float *) PTR(obj))->value);
556 break;
557
558 #ifdef type_LongFloat
559 case type_LongFloat:
560 NEWLINE;
561 printf("%Lg", ((struct long_float *) PTR(obj))->value);
562 break;
563 #endif
564
565 #ifdef type_DoubleDoubleFloat
566 case type_DoubleDoubleFloat:
567 NEWLINE;
568 printf("%g %g", ((struct double_double_float *) PTR(obj))->hi,
569 ((struct double_double_float *) PTR(obj))->lo);
570 break;
571 #endif
572
573 #ifdef type_ComplexSingleFloat
574 case type_ComplexSingleFloat:
575 NEWLINE;
576 printf("%g", ((struct complex_single_float *) PTR(obj))->real);
577 NEWLINE;
578 printf("%g", ((struct complex_single_float *) PTR(obj))->imag);
579 break;
580 #endif
581
582 #ifdef type_ComplexDoubleFloat
583 case type_ComplexDoubleFloat:
584 NEWLINE;
585 printf("%g", ((struct complex_double_float *) PTR(obj))->real);
586 NEWLINE;
587 printf("%g", ((struct complex_double_float *) PTR(obj))->imag);
588 break;
589 #endif
590
591 #ifdef type_ComplexLongFloat
592 case type_ComplexLongFloat:
593 NEWLINE;
594 printf("%Lg", ((struct complex_long_float *) PTR(obj))->real);
595 NEWLINE;
596 printf("%Lg", ((struct complex_long_float *) PTR(obj))->imag);
597 break;
598 #endif
599
600 #ifdef type_ComplexDoubleDoubleFloat
601 case type_ComplexDoubleDoubleFloat:
602 NEWLINE;
603 printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->real_hi,
604 ((struct complex_double_double_float *) PTR(obj))->real_lo);
605 NEWLINE;
606 printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->imag_hi,
607 ((struct complex_double_double_float *) PTR(obj))->imag_lo);
608 break;
609 #endif
610
611
612 case type_SimpleString:
613 NEWLINE;
614 putchar('\"');
615 /* Need to back up one to get the start of the vector */
616 print_string((struct vector*) (ptr - 1));
617 putchar('\"');
618 break;
619
620 case type_SimpleVector:
621 NEWLINE;
622 printf("length = %ld", length);
623 ptr++;
624 index = 0;
625 while (length-- > 0) {
626 sprintf(buffer, "%d: ", index++);
627 print_obj(buffer, *ptr++);
628 }
629 break;
630
631 case type_InstanceHeader:
632 NEWLINE;
633 printf("length = %d", count);
634 index = 0;
635 while (count-- > 0) {
636 sprintf(buffer, "%d: ", index++);
637 print_obj(buffer, *ptr++);
638 }
639 break;
640
641 case type_SimpleArray:
642 case type_SimpleBitVector:
643 case type_SimpleArrayUnsignedByte2:
644 case type_SimpleArrayUnsignedByte4:
645 case type_SimpleArrayUnsignedByte8:
646 case type_SimpleArrayUnsignedByte16:
647 case type_SimpleArrayUnsignedByte32:
648 #ifdef type_SimpleArraySignedByte8
649 case type_SimpleArraySignedByte8:
650 #endif
651 #ifdef type_SimpleArraySignedByte16
652 case type_SimpleArraySignedByte16:
653 #endif
654 #ifdef type_SimpleArraySignedByte30
655 case type_SimpleArraySignedByte30:
656 #endif
657 #ifdef type_SimpleArraySignedByte32
658 case type_SimpleArraySignedByte32:
659 #endif
660 case type_SimpleArraySingleFloat:
661 case type_SimpleArrayDoubleFloat:
662 #ifdef type_SimpleArrayLongFloat
663 case type_SimpleArrayLongFloat:
664 #endif
665 #ifdef type_SimpleArrayDoubleDoubleFloat
666 case type_SimpleArrayDoubleDoubleFloat:
667 #endif
668 #ifdef type_SimpleArrayComplexSingleFloat
669 case type_SimpleArrayComplexSingleFloat:
670 #endif
671 #ifdef type_SimpleArrayComplexDoubleFloat
672 case type_SimpleArrayComplexDoubleFloat:
673 #endif
674 #ifdef type_SimpleArrayComplexLongFloat
675 case type_SimpleArrayComplexLongFloat:
676 #endif
677 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
678 case type_SimpleArrayComplexDoubleDoubleFloat:
679 #endif
680 print_slots(simple_array_slots, 1, ptr);
681 break;
682 case type_ComplexString:
683 case type_ComplexBitVector:
684 case type_ComplexVector:
685 case type_ComplexArray:
686 print_slots(array_slots, count, ptr);
687 break;
688
689 case type_CodeHeader:
690 print_slots(code_slots, count - 1, ptr);
691 break;
692
693 case type_FunctionHeader:
694 case type_ClosureFunctionHeader:
695 print_slots(fn_slots, 5, ptr);
696 break;
697
698 case type_ReturnPcHeader:
699 print_obj("code: ", obj - (count * 4));
700 break;
701
702 case type_ClosureHeader:
703 print_slots(closure_slots, count, ptr);
704 break;
705
706 case type_FuncallableInstanceHeader:
707 print_slots(funcallable_instance_slots, count, ptr);
708 break;
709
710 case type_ValueCellHeader:
711 print_slots(value_cell_slots, 1, ptr);
712 break;
713
714 case type_Sap:
715 NEWLINE;
716 #ifndef alpha
717 printf("0x%08lx", *ptr);
718 #else
719 printf("0x%016lx", *(long *) (ptr + 1));
720 #endif
721 break;
722
723 case type_WeakPointer:
724 print_slots(weak_pointer_slots, 3, ptr);
725 break;
726
727 case type_BaseChar:
728 case type_UnboundMarker:
729 NEWLINE;
730 printf("pointer to an immediate?");
731 break;
732
733 case type_Fdefn:
734 print_slots(fdefn_slots, count, ptr);
735 break;
736
737 #ifdef type_ScavengerHook
738 case type_ScavengerHook:
739 print_slots(scavenger_hook_slots, count, ptr);
740 break;
741 #endif
742
743 default:
744 NEWLINE;
745 printf("Unknown header object?");
746 break;
747 }
748 }
749 }
750
751 static void
752 print_obj(char *prefix, lispobj obj)
753 {
754 static void (*verbose_fns[]) (lispobj obj)
755 = { print_fixnum, print_otherptr, print_otherimm, print_list,
756 print_fixnum, print_struct, print_otherimm, print_otherptr
757 };
758 static void (*brief_fns[]) (lispobj obj)
759 = { brief_fixnum, brief_otherptr, brief_otherimm, brief_list,
760 brief_fixnum, brief_struct, brief_otherimm, brief_otherptr
761 };
762 int type = LowtagOf(obj);
763 struct var *var = lookup_by_obj(obj);
764 char buffer[256];
765 boolean verbose = cur_depth < brief_depth;
766
767
768 if (!continue_p(verbose))
769 return;
770
771 if (var != NULL && var_clock(var) == cur_clock)
772 dont_decend = TRUE;
773
774 if (var == NULL
775 && (obj & type_FunctionPointer & type_ListPointer & type_InstancePointer
776 & type_OtherPointer) != 0)
777 var = define_var(NULL, obj, FALSE);
778
779 if (var != NULL)
780 var_setclock(var, cur_clock);
781
782 cur_depth++;
783 if (verbose) {
784 if (var != NULL) {
785 sprintf(buffer, "$%s=", var_name(var));
786 newline(buffer);
787 } else
788 newline(NULL);
789 printf("%s0x%08lx: ", prefix, obj);
790 if (cur_depth < brief_depth) {
791 fputs(lowtag_Names[type], stdout);
792 (*verbose_fns[type]) (obj);
793 } else
794 (*brief_fns[type]) (obj);
795 } else {
796 if (dont_decend)
797 printf("$%s", var_name(var));
798 else {
799 if (var != NULL)
800 printf("$%s=", var_name(var));
801 (*brief_fns[type]) (obj);
802 }
803 }
804 cur_depth--;
805 dont_decend = FALSE;
806 }
807
808 void
809 reset_printer(void)
810 {
811 cur_clock++;
812 cur_lines = 0;
813 dont_decend = FALSE;
814 }
815
816 void
817 print(lispobj obj)
818 {
819 skip_newline = TRUE;
820 cur_depth = 0;
821 max_depth = 5;
822 max_lines = 20;
823
824 print_obj("", obj);
825
826 putchar('\n');
827 }
828
829 void
830 brief_print(lispobj obj)
831 {
832 skip_newline = TRUE;
833 cur_depth = 0;
834 max_depth = 1;
835 max_lines = 5000;
836
837 print_obj("", obj);
838 putchar('\n');
839 }

  ViewVC Help
Powered by ViewVC 1.1.5