source: release/1.7/source/lisp-kernel/x86_print.c @ 15267

Last change on this file since 15267 was 14716, checked in by rme, 8 years ago

In sprint_specializers_list(), make sure that we're looking at
an instance before we go looking for the class name in it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.3 KB
Line 
1/*
2   Copyright (C) 2005-2009, Clozure Associates
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include <stdio.h>
18#include <stdarg.h>
19#include <setjmp.h>
20
21#include "lisp.h"
22#include "area.h"
23#include "lisp-exceptions.h"
24#include "lisp_globals.h"
25
26void
27sprint_lisp_object(LispObj, int);
28
29#define PBUFLEN 252
30
31char printbuf[PBUFLEN + 4];
32int bufpos = 0;
33
34jmp_buf escape;
35
36void
37add_char(char c)
38{
39  if (bufpos >= PBUFLEN) {
40    longjmp(escape, 1);
41  } else {
42    printbuf[bufpos++] = c;
43  }
44}
45
46void
47add_string(char *s, int len) 
48{
49  while(len--) {
50    add_char(*s++);
51  }
52}
53
54void
55add_lisp_base_string(LispObj str)
56{
57  lisp_char_code *src = (lisp_char_code *)  (ptr_from_lispobj(str + misc_data_offset));
58  natural i, n = header_element_count(header_of(str));
59
60  for (i=0; i < n; i++) {
61    add_char((char)(*src++));
62  }
63}
64
65void
66add_c_string(char *s)
67{
68  add_string(s, strlen(s));
69}
70
71char numbuf[64], *digits = "0123456789ABCDEF";
72
73
74void
75sprint_unsigned_decimal_aux(natural n, Boolean first)
76{
77  if (n == 0) {
78    if (first) {
79      add_char('0');
80    }
81  } else {
82    sprint_unsigned_decimal_aux(n/10, false);
83    add_char(digits[n%10]);
84  }
85}
86
87void
88sprint_unsigned_decimal(natural n)
89{
90  sprint_unsigned_decimal_aux(n, true);
91}
92
93void
94sprint_signed_decimal(signed_natural n)
95{
96  if (n < 0) {
97    add_char('-');
98    n = -n;
99  }
100  sprint_unsigned_decimal(n);
101}
102
103
104void
105sprint_unsigned_hex(natural n)
106{
107  int i, 
108    ndigits =
109#if WORD_SIZE == 64
110    16
111#else
112    8
113#endif
114    ;
115
116  add_c_string("#x");
117  for (i = 0; i < ndigits; i++) {
118    add_char(digits[(n>>(4*(ndigits-(i+1))))&15]);
119  }
120}
121
122void
123sprint_list(LispObj o, int depth)
124{
125  LispObj the_cdr;
126 
127  add_char('(');
128  while(1) {
129    if (o != lisp_nil) {
130      sprint_lisp_object(ptr_to_lispobj(car(o)), depth);
131      the_cdr = ptr_to_lispobj(cdr(o));
132      if (the_cdr != lisp_nil) {
133        add_char(' ');
134        if (fulltag_of(the_cdr) == fulltag_cons) {
135          o = the_cdr;
136          continue;
137        }
138        add_c_string(". ");
139        sprint_lisp_object(the_cdr, depth);
140        break;
141      }
142    }
143    break;
144  }
145  add_char(')');
146}
147
148/*
149  Print a list of method specializers, using the class name instead of the class object.
150*/
151
152void
153sprint_specializers_list(LispObj o, int depth)
154{
155  LispObj the_cdr, the_car;
156 
157  add_char('(');
158  while(1) {
159    if (o != lisp_nil) {
160      the_car = car(o);
161      if (fulltag_of(the_car) == fulltag_misc) {
162        LispObj header = header_of(the_car);
163        unsigned subtag = header_subtag(header);
164
165        if (subtag == subtag_instance) {
166          sprint_lisp_object(deref(deref(the_car,3), 4), depth);
167        } else {
168          sprint_lisp_object(the_car, depth);
169        }
170      } else {
171        sprint_lisp_object(the_car, depth);
172      }
173      the_cdr = cdr(o);
174      if (the_cdr != lisp_nil) {
175        add_char(' ');
176        if (fulltag_of(the_cdr) == fulltag_cons) {
177          o = the_cdr;
178          continue;
179        }
180        add_c_string(". ");
181        sprint_lisp_object(the_cdr, depth);
182        break;
183      }
184    }
185    break;
186  }
187  add_char(')');
188}
189
190char *
191vector_subtag_name(unsigned subtag)
192{
193  switch (subtag) {
194  case subtag_bit_vector:
195    return "BIT-VECTOR";
196    break;
197  case subtag_instance:
198    return "INSTANCE";
199    break;
200  case subtag_bignum:
201    return "BIGNUM";
202    break;
203  case subtag_u8_vector:
204    return "(UNSIGNED-BYTE 8)";
205    break;
206  case subtag_s8_vector:
207    return "(SIGNED-BYTE 8)";
208    break;
209  case subtag_u16_vector:
210    return "(UNSIGNED-BYTE 16)";
211    break;
212  case subtag_s16_vector:
213    return "(SIGNED-BYTE 16)";
214    break;
215  case subtag_u32_vector:
216    return "(UNSIGNED-BYTE 32)";
217    break;
218  case subtag_s32_vector:
219    return "(SIGNED-BYTE 32)";
220    break;
221#ifdef X8664
222  case subtag_u64_vector:
223    return "(UNSIGNED-BYTE 64)";
224    break;
225  case subtag_s64_vector:
226    return "(SIGNED-BYTE 64)";
227    break;
228#endif
229  case subtag_package:
230    return "PACKAGE";
231    break;
232  case subtag_slot_vector:
233    return "SLOT-VECTOR";
234    break;
235  default:
236    return "";
237    break;
238  }
239}
240
241
242void
243sprint_random_vector(LispObj o, unsigned subtag, natural elements)
244{
245  add_c_string("#<");
246  sprint_unsigned_decimal(elements);
247  add_c_string("-element vector subtag = #x");
248  add_char(digits[subtag>>4]);
249  add_char(digits[subtag&15]);
250  add_c_string(" @");
251  sprint_unsigned_hex(o);
252  add_c_string(" (");
253  add_c_string(vector_subtag_name(subtag));
254  add_c_string(")>");
255}
256
257void
258sprint_symbol(LispObj o)
259{
260  lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o));
261  LispObj
262    pname = rawsym->pname,
263    package = rawsym->package_predicate;
264
265  if (fulltag_of(package) == fulltag_cons) {
266    package = car(package);
267  }
268
269  if (package == nrs_KEYWORD_PACKAGE.vcell) {
270    add_char(':');
271  }
272  add_lisp_base_string(pname);
273}
274
275#ifdef X8632
276LispObj
277nth_immediate(LispObj o, unsigned n)
278{
279  u16_t imm_word_count = *(u16_t *)(o + misc_data_offset);
280  natural *constants = (natural *)((char *)o + misc_data_offset + (imm_word_count << 2));
281  LispObj result = (LispObj)(constants[n-1]);
282
283  return result;
284}
285#endif
286
287void
288sprint_function(LispObj o, int depth)
289{
290  LispObj lfbits, header, name = lisp_nil;
291  natural elements;
292
293  header = header_of(o);
294  elements = header_element_count(header);
295  lfbits = deref(o, elements);
296
297  if ((lfbits & lfbits_noname_mask) == 0) {
298    name = deref(o, elements-1);
299  }
300 
301  add_c_string("#<");
302  if (name == lisp_nil) {
303    add_c_string("Anonymous Function ");
304  } else {
305    if (lfbits & lfbits_method_mask) {
306      if (header_subtag(header_of(name)) == subtag_instance) {
307        LispObj
308          slot_vector = deref(name,3),
309          method_name = deref(slot_vector, 6),
310          method_qualifiers = deref(slot_vector, 2),
311          method_specializers = deref(slot_vector, 3);
312        add_c_string("Method-Function ");
313        sprint_lisp_object(method_name, depth);
314        add_char(' ');
315        if (method_qualifiers != lisp_nil) {
316          if (cdr(method_qualifiers) == lisp_nil) {
317            sprint_lisp_object(car(method_qualifiers), depth);
318          } else {
319            sprint_lisp_object(method_qualifiers, depth);
320          }
321          add_char(' ');
322        }
323        sprint_specializers_list(method_specializers, depth);
324      }
325      else {
326        sprint_lisp_object(name,depth);
327      }
328      add_char(' ');
329    } else if (lfbits & lfbits_gfn_mask) {
330      add_c_string("Generic Function ");
331
332#ifdef X8632
333      {
334        LispObj gf_slots = nth_immediate(o, 2);
335        LispObj gf_name = deref(gf_slots, 2);
336
337        sprint_lisp_object(gf_name, depth);
338        add_char(' ');
339      }
340#endif
341    } else {
342      add_c_string("Function ");
343      sprint_lisp_object(name, depth);
344      add_char(' ');
345    }
346  }
347  sprint_unsigned_hex(o);
348  add_char('>');
349}
350
351void
352sprint_tra(LispObj o, int depth)
353{
354#ifdef X8664
355  signed sdisp;
356  unsigned disp = 0;
357  LispObj f = 0;
358
359  if ((*((unsigned short *)o) == RECOVER_FN_FROM_RIP_WORD0) &&
360      (*((unsigned char *)(o+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
361    sdisp = (*(int *) (o+3));
362    f = RECOVER_FN_FROM_RIP_LENGTH+o+sdisp;
363    disp = o-f;
364  }
365
366  if (fulltag_of(f) == fulltag_function) {
367    add_c_string("tagged return address: ");
368    sprint_function(f, depth);
369    add_c_string(" + ");
370    sprint_unsigned_decimal(disp);
371  } else {
372    add_c_string("(tra ?) : ");
373    sprint_unsigned_hex(o);
374  }
375#else
376  LispObj f = 0;
377  unsigned disp = 0;
378
379  if (*(unsigned char *)o == RECOVER_FN_OPCODE) {
380    f = (LispObj)(*((natural *)(o + 1)));
381    disp = o - f;
382  }
383
384  if (f && header_subtag(header_of(f)) == subtag_function) {
385    add_c_string("tagged return address: ");
386    sprint_function(f, depth);
387    add_c_string(" + ");
388    sprint_unsigned_decimal(disp);
389  } else {
390    add_c_string("(tra ?) : ");
391    sprint_unsigned_hex(o);
392  }
393#endif
394}
395               
396void
397sprint_gvector(LispObj o, int depth)
398{
399  LispObj header = header_of(o);
400  unsigned 
401    elements = header_element_count(header),
402    subtag = header_subtag(header);
403   
404  switch(subtag) {
405  case subtag_function:
406    sprint_function(o, depth);
407    break;
408   
409  case subtag_symbol:
410    sprint_symbol(o);
411    break;
412   
413  case subtag_struct:
414  case subtag_istruct:
415    add_c_string("#<");
416    sprint_lisp_object(deref(o,1), depth);
417    add_c_string(" @");
418    sprint_unsigned_hex(o);
419    add_c_string(">");
420    break;
421   
422  case subtag_simple_vector:
423    {
424      int i;
425      add_c_string("#(");
426      for(i = 1; i <= elements; i++) {
427        if (i > 1) {
428          add_char(' ');
429        }
430        sprint_lisp_object(deref(o, i), depth);
431      }
432      add_char(')');
433      break;
434    }
435
436  case subtag_instance:
437    {
438      LispObj class_or_hash = deref(o,1);
439     
440      if (tag_of(class_or_hash) == tag_fixnum) {
441        sprint_random_vector(o, subtag, elements);
442      } else {
443        add_c_string("#<CLASS ");
444        sprint_lisp_object(class_or_hash, depth);
445        add_c_string(" @");
446        sprint_unsigned_hex(o);
447        add_c_string(">");
448      }
449      break;
450    }
451
452       
453     
454  default:
455    sprint_random_vector(o, subtag, elements);
456    break;
457  }
458}
459
460void
461sprint_ivector(LispObj o)
462{
463  LispObj header = header_of(o);
464  unsigned 
465    elements = header_element_count(header),
466    subtag = header_subtag(header);
467   
468  switch(subtag) {
469  case subtag_simple_base_string:
470    add_char('"');
471    add_lisp_base_string(o);
472    add_char('"');
473    return;
474   
475  case subtag_bignum:
476    if (elements == 1) {
477      sprint_signed_decimal((signed_natural)(deref(o, 1)));
478      return;
479    }
480    if ((elements == 2) && (deref(o, 2) == 0)) {
481      sprint_unsigned_decimal(deref(o, 1));
482      return;
483    }
484    break;
485   
486  case subtag_double_float:
487    break;
488
489  case subtag_macptr:
490    add_c_string("#<MACPTR ");
491    sprint_unsigned_hex(deref(o,1));
492    add_c_string(">");
493    break;
494
495  default:
496    sprint_random_vector(o, subtag, elements);
497  }
498}
499
500void
501sprint_vector(LispObj o, int depth)
502{
503  LispObj header = header_of(o);
504 
505  if (immheader_tag_p(fulltag_of(header))) {
506    sprint_ivector(o);
507  } else {
508    sprint_gvector(o, depth);
509  }
510}
511
512void
513sprint_lisp_object(LispObj o, int depth) 
514{
515  if (--depth < 0) {
516    add_char('#');
517  } else {
518    switch (fulltag_of(o)) {
519    case fulltag_even_fixnum:
520    case fulltag_odd_fixnum:
521      sprint_signed_decimal(unbox_fixnum(o));
522      break;
523   
524#ifdef X8664
525    case fulltag_immheader_0:
526    case fulltag_immheader_1:
527    case fulltag_immheader_2:
528    case fulltag_nodeheader_0:
529    case fulltag_nodeheader_1:
530#else
531    case fulltag_immheader:
532    case fulltag_nodeheader:
533#endif     
534      add_c_string("#<header ? ");
535      sprint_unsigned_hex(o);
536      add_c_string(">");
537      break;
538
539#ifdef X8664
540    case fulltag_imm_0:
541    case fulltag_imm_1:
542#else
543    case fulltag_imm:
544#endif
545      if (o == unbound) {
546        add_c_string("#<Unbound>");
547      } else {
548        if (header_subtag(o) == subtag_character) {
549          unsigned c = (o >> charcode_shift);
550          add_c_string("#\\");
551          if ((c >= ' ') && (c < 0x7f)) {
552            add_char(c);
553          } else {
554            sprintf(numbuf, "%#o", c);
555            add_c_string(numbuf);
556          }
557#ifdef X8664
558        } else if (header_subtag(o) == subtag_single_float) {
559          LispObj xx = o;
560          float f = ((float *)&xx)[1];
561          sprintf(numbuf, "%f", f);
562          add_c_string(numbuf);
563#endif
564        } else {
565
566          add_c_string("#<imm ");
567          sprint_unsigned_hex(o);
568          add_c_string(">");
569        }
570      }
571      break;
572
573#ifdef X8664
574    case fulltag_nil:
575#endif
576    case fulltag_cons:
577      sprint_list(o, depth);
578      break;
579     
580    case fulltag_misc:
581      sprint_vector(o, depth);
582      break;
583
584#ifdef X8664
585    case fulltag_symbol:
586      sprint_symbol(o);
587      break;
588
589    case fulltag_function:
590      sprint_function(o, depth);
591      break;
592#endif
593
594#ifdef X8664
595    case fulltag_tra_0:
596    case fulltag_tra_1:
597#else
598    case fulltag_tra:
599#endif
600      sprint_tra(o,depth);
601      break;
602    }
603  }
604}
605
606char *
607print_lisp_object(LispObj o)
608{
609  bufpos = 0;
610  if (setjmp(escape) == 0) {
611    sprint_lisp_object(o, 5);
612    printbuf[bufpos] = 0;
613  } else {
614    printbuf[PBUFLEN+0] = '.';
615    printbuf[PBUFLEN+1] = '.';
616    printbuf[PBUFLEN+2] = '.';
617    printbuf[PBUFLEN+3] = 0;
618  }
619  return printbuf;
620}
Note: See TracBrowser for help on using the repository browser.