source: trunk/ccl/lisp-kernel/x86_print.c @ 6522

Last change on this file since 6522 was 6522, checked in by gb, 14 years ago

New tra handling.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.9 KB
Line 
1/*
2   Copyright (C) 2005, Clozure Associates
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL 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        sprint_lisp_object(deref(deref(the_car,3), 4), depth);
163      } else {
164        sprint_lisp_object(the_car, depth);
165      }
166      the_cdr = cdr(o);
167      if (the_cdr != lisp_nil) {
168        add_char(' ');
169        if (fulltag_of(the_cdr) == fulltag_cons) {
170          o = the_cdr;
171          continue;
172        }
173        add_c_string(". ");
174        sprint_lisp_object(the_cdr, depth);
175        break;
176      }
177    }
178    break;
179  }
180  add_char(')');
181}
182
183char *
184vector_subtag_name(unsigned subtag)
185{
186  switch (subtag) {
187  case subtag_bit_vector:
188    return "BIT-VECTOR";
189    break;
190  case subtag_instance:
191    return "INSTANCE";
192    break;
193  case subtag_bignum:
194    return "BIGNUM";
195    break;
196  case subtag_u8_vector:
197    return "(UNSIGNED-BYTE 8)";
198    break;
199  case subtag_s8_vector:
200    return "(SIGNED-BYTE 8)";
201    break;
202  case subtag_u16_vector:
203    return "(UNSIGNED-BYTE 16)";
204    break;
205  case subtag_s16_vector:
206    return "(SIGNED-BYTE 16)";
207    break;
208  case subtag_u32_vector:
209    return "(UNSIGNED-BYTE 32)";
210    break;
211  case subtag_s32_vector:
212    return "(SIGNED-BYTE 32)";
213    break;
214#ifdef X8664
215  case subtag_u64_vector:
216    return "(UNSIGNED-BYTE 64)";
217    break;
218  case subtag_s64_vector:
219    return "(SIGNED-BYTE 64)";
220    break;
221#endif
222  case subtag_package:
223    return "PACKAGE";
224    break;
225  case subtag_slot_vector:
226    return "SLOT-VECTOR";
227    break;
228  default:
229    return "";
230    break;
231  }
232}
233
234
235void
236sprint_random_vector(LispObj o, unsigned subtag, natural elements)
237{
238  add_c_string("#<");
239  sprint_unsigned_decimal(elements);
240  add_c_string("-element vector subtag = ");
241  add_char(digits[subtag>>4]);
242  add_char(digits[subtag&15]);
243  add_c_string(" @");
244  sprint_unsigned_hex(o);
245  add_c_string(" (");
246  add_c_string(vector_subtag_name(subtag));
247  add_c_string(")>");
248}
249
250void
251sprint_symbol(LispObj o)
252{
253  lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o));
254  LispObj
255    pname = rawsym->pname,
256    package = rawsym->package_predicate,
257    pname_header = header_of(pname);
258
259  if (fulltag_of(package) == fulltag_cons) {
260    package = car(package);
261  }
262
263  if (package == nrs_KEYWORD_PACKAGE.vcell) {
264    add_char(':');
265  }
266  add_lisp_base_string(pname);
267}
268
269void
270sprint_function(LispObj o, int depth)
271{
272  LispObj lfbits, header, name = lisp_nil;
273  natural elements;
274
275  header = header_of(o);
276  elements = header_element_count(header);
277  lfbits = deref(o, elements);
278
279  if ((lfbits & lfbits_noname_mask) == 0) {
280    name = deref(o, elements-1);
281  }
282 
283  add_c_string("#<");
284  if (name == lisp_nil) {
285    add_c_string("Anonymous Function ");
286  } else {
287    if (lfbits & lfbits_method_mask) {
288      LispObj
289        slot_vector = deref(name,3),
290        method_name = deref(slot_vector, 6),
291        method_qualifiers = deref(slot_vector, 2),
292        method_specializers = deref(slot_vector, 3);
293      add_c_string("Method-Function ");
294      sprint_lisp_object(method_name, depth);
295      add_char(' ');
296      if (method_qualifiers != lisp_nil) {
297        if (cdr(method_qualifiers) == lisp_nil) {
298          sprint_lisp_object(car(method_qualifiers), depth);
299        } else {
300          sprint_lisp_object(method_qualifiers, depth);
301        }
302        add_char(' ');
303      }
304      sprint_specializers_list(method_specializers, depth);
305      add_char(' ');
306    } else {
307      add_c_string("Function ");
308      sprint_lisp_object(name, depth);
309      add_char(' ');
310    }
311  }
312  sprint_unsigned_hex(o);
313  add_char('>');
314}
315
316void
317sprint_tra(LispObj o, int depth)
318{
319  signed sdisp;
320  unsigned disp;
321  LispObj f = 0;
322
323  if ((*((unsigned short *)o) == RECOVER_FN_FROM_RIP_WORD0) &&
324      (*((unsigned char *)(o+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
325    sdisp = (*(int *) (o+3));
326    f = RECOVER_FN_FROM_RIP_LENGTH+o+sdisp;
327    disp = o-f;
328  }
329
330  if (fulltag_of(f) == fulltag_function) {
331    add_c_string("tagged return address: ");
332    sprint_function(f, depth);
333    add_c_string(" + ");
334    sprint_unsigned_decimal(disp);
335  } else {
336    add_c_string("(tra ?) : ");
337    sprint_unsigned_hex(o);
338  }
339}
340               
341void
342sprint_gvector(LispObj o, int depth)
343{
344  LispObj header = header_of(o);
345  unsigned 
346    elements = header_element_count(header),
347    subtag = header_subtag(header);
348   
349  switch(subtag) {
350  case subtag_function:
351    sprint_function(o, depth);
352    break;
353   
354  case subtag_symbol:
355    sprint_symbol(o);
356    break;
357   
358  case subtag_struct:
359  case subtag_istruct:
360    add_c_string("#<");
361    sprint_lisp_object(deref(o,1), depth);
362    add_c_string(" @");
363    sprint_unsigned_hex(o);
364    add_c_string(">");
365    break;
366   
367  case subtag_simple_vector:
368    {
369      int i;
370      add_c_string("#(");
371      for(i = 1; i <= elements; i++) {
372        if (i > 1) {
373          add_char(' ');
374        }
375        sprint_lisp_object(deref(o, i), depth);
376      }
377      add_char(')');
378      break;
379    }
380
381  case subtag_instance:
382    {
383      LispObj class_or_hash = deref(o,1);
384     
385      if (tag_of(class_or_hash) == tag_fixnum) {
386        sprint_random_vector(o, subtag, elements);
387      } else {
388        add_c_string("#<CLASS ");
389        sprint_lisp_object(class_or_hash, depth);
390        add_c_string(" @");
391        sprint_unsigned_hex(o);
392        add_c_string(">");
393      }
394      break;
395    }
396
397       
398     
399  default:
400    sprint_random_vector(o, subtag, elements);
401    break;
402  }
403}
404
405void
406sprint_ivector(LispObj o)
407{
408  LispObj header = header_of(o);
409  unsigned 
410    elements = header_element_count(header),
411    subtag = header_subtag(header);
412   
413  switch(subtag) {
414  case subtag_simple_base_string:
415    add_char('"');
416    add_lisp_base_string(o);
417    add_char('"');
418    return;
419   
420  case subtag_bignum:
421    if (elements == 1) {
422      sprint_signed_decimal((signed_natural)(deref(o, 1)));
423      return;
424    }
425    if ((elements == 2) && (deref(o, 2) == 0)) {
426      sprint_unsigned_decimal(deref(o, 1));
427      return;
428    }
429    break;
430   
431  case subtag_double_float:
432    break;
433
434  case subtag_macptr:
435    add_c_string("#<MACPTR ");
436    sprint_unsigned_hex(deref(o,1));
437    add_c_string(">");
438    break;
439
440  default:
441    sprint_random_vector(o, subtag, elements);
442  }
443}
444
445void
446sprint_vector(LispObj o, int depth)
447{
448  LispObj header = header_of(o);
449 
450  if (immheader_tag_p(fulltag_of(header))) {
451    sprint_ivector(o);
452  } else {
453    sprint_gvector(o, depth);
454  }
455}
456
457void
458sprint_lisp_object(LispObj o, int depth) 
459{
460  if (--depth < 0) {
461    add_char('#');
462  } else {
463    switch (fulltag_of(o)) {
464    case fulltag_even_fixnum:
465    case fulltag_odd_fixnum:
466      sprint_signed_decimal(unbox_fixnum(o));
467      break;
468   
469#ifdef X8664
470    case fulltag_immheader_0:
471    case fulltag_immheader_1:
472    case fulltag_immheader_2:
473    case fulltag_nodeheader_0:
474    case fulltag_nodeheader_1:
475#else
476#endif     
477      add_c_string("#<header ? ");
478      sprint_unsigned_hex(o);
479      add_c_string(">");
480      break;
481
482#ifdef X8664
483    case fulltag_imm_0:
484    case fulltag_imm_1:
485#else
486#endif
487      if (o == unbound) {
488        add_c_string("#<Unbound>");
489      } else {
490        if (header_subtag(o) == subtag_character) {
491          unsigned c = (o >> charcode_shift);
492          add_c_string("#\\");
493          if ((c >= ' ') && (c < 0x7f)) {
494            add_char(c);
495          } else {
496            sprintf(numbuf, "%o", c);
497            add_c_string(numbuf);
498          }
499#ifdef X8664
500        } else if (header_subtag(o) == subtag_single_float) {
501          LispObj xx = o;
502          float f = ((float *)&xx)[1];
503          sprintf(numbuf, "%f", f);
504          add_c_string(numbuf);
505#endif
506        } else {
507
508          add_c_string("#<imm ");
509          sprint_unsigned_hex(o);
510          add_c_string(">");
511        }
512      }
513      break;
514   
515    case fulltag_nil:
516    case fulltag_cons:
517      sprint_list(o, depth);
518      break;
519     
520    case fulltag_misc:
521      sprint_vector(o, depth);
522      break;
523
524    case fulltag_symbol:
525      sprint_symbol(o);
526      break;
527
528    case fulltag_function:
529      sprint_function(o, depth);
530      break;
531
532    case fulltag_tra_0:
533    case fulltag_tra_1:
534      sprint_tra(o,depth);
535      break;
536    }
537  }
538}
539
540char *
541print_lisp_object(LispObj o)
542{
543  bufpos = 0;
544  if (setjmp(escape) == 0) {
545    sprint_lisp_object(o, 5);
546    printbuf[bufpos] = 0;
547  } else {
548    printbuf[PBUFLEN+0] = '.';
549    printbuf[PBUFLEN+1] = '.';
550    printbuf[PBUFLEN+2] = '.';
551    printbuf[PBUFLEN+3] = 0;
552  }
553  return printbuf;
554}
Note: See TracBrowser for help on using the repository browser.