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