source: trunk/source/lisp-kernel/x86_print.c @ 9901

Last change on this file since 9901 was 9901, checked in by gb, 12 years ago

Remove unused variables. (May need to compile with -Wall to find
more unused vars on PPC, too.)

  • 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
258  if (fulltag_of(package) == fulltag_cons) {
259    package = car(package);
260  }
261
262  if (package == nrs_KEYWORD_PACKAGE.vcell) {
263    add_char(':');
264  }
265  add_lisp_base_string(pname);
266}
267
268void
269sprint_function(LispObj o, int depth)
270{
271  LispObj lfbits, header, name = lisp_nil;
272  natural elements;
273
274  header = header_of(o);
275  elements = header_element_count(header);
276  lfbits = deref(o, elements);
277
278  if ((lfbits & lfbits_noname_mask) == 0) {
279    name = deref(o, elements-1);
280  }
281 
282  add_c_string("#<");
283  if (name == lisp_nil) {
284    add_c_string("Anonymous Function ");
285  } else {
286    if (lfbits & lfbits_method_mask) {
287      LispObj
288        slot_vector = deref(name,3),
289        method_name = deref(slot_vector, 6),
290        method_qualifiers = deref(slot_vector, 2),
291        method_specializers = deref(slot_vector, 3);
292      add_c_string("Method-Function ");
293      sprint_lisp_object(method_name, depth);
294      add_char(' ');
295      if (method_qualifiers != lisp_nil) {
296        if (cdr(method_qualifiers) == lisp_nil) {
297          sprint_lisp_object(car(method_qualifiers), depth);
298        } else {
299          sprint_lisp_object(method_qualifiers, depth);
300        }
301        add_char(' ');
302      }
303      sprint_specializers_list(method_specializers, depth);
304      add_char(' ');
305    } else {
306      add_c_string("Function ");
307      sprint_lisp_object(name, depth);
308      add_char(' ');
309    }
310  }
311  sprint_unsigned_hex(o);
312  add_char('>');
313}
314
315void
316sprint_tra(LispObj o, int depth)
317{
318  signed sdisp;
319  unsigned disp = 0;
320  LispObj f = 0;
321
322  if ((*((unsigned short *)o) == RECOVER_FN_FROM_RIP_WORD0) &&
323      (*((unsigned char *)(o+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
324    sdisp = (*(int *) (o+3));
325    f = RECOVER_FN_FROM_RIP_LENGTH+o+sdisp;
326    disp = o-f;
327  }
328
329  if (fulltag_of(f) == fulltag_function) {
330    add_c_string("tagged return address: ");
331    sprint_function(f, depth);
332    add_c_string(" + ");
333    sprint_unsigned_decimal(disp);
334  } else {
335    add_c_string("(tra ?) : ");
336    sprint_unsigned_hex(o);
337  }
338}
339               
340void
341sprint_gvector(LispObj o, int depth)
342{
343  LispObj header = header_of(o);
344  unsigned 
345    elements = header_element_count(header),
346    subtag = header_subtag(header);
347   
348  switch(subtag) {
349  case subtag_function:
350    sprint_function(o, depth);
351    break;
352   
353  case subtag_symbol:
354    sprint_symbol(o);
355    break;
356   
357  case subtag_struct:
358  case subtag_istruct:
359    add_c_string("#<");
360    sprint_lisp_object(deref(o,1), depth);
361    add_c_string(" @");
362    sprint_unsigned_hex(o);
363    add_c_string(">");
364    break;
365   
366  case subtag_simple_vector:
367    {
368      int i;
369      add_c_string("#(");
370      for(i = 1; i <= elements; i++) {
371        if (i > 1) {
372          add_char(' ');
373        }
374        sprint_lisp_object(deref(o, i), depth);
375      }
376      add_char(')');
377      break;
378    }
379
380  case subtag_instance:
381    {
382      LispObj class_or_hash = deref(o,1);
383     
384      if (tag_of(class_or_hash) == tag_fixnum) {
385        sprint_random_vector(o, subtag, elements);
386      } else {
387        add_c_string("#<CLASS ");
388        sprint_lisp_object(class_or_hash, depth);
389        add_c_string(" @");
390        sprint_unsigned_hex(o);
391        add_c_string(">");
392      }
393      break;
394    }
395
396       
397     
398  default:
399    sprint_random_vector(o, subtag, elements);
400    break;
401  }
402}
403
404void
405sprint_ivector(LispObj o)
406{
407  LispObj header = header_of(o);
408  unsigned 
409    elements = header_element_count(header),
410    subtag = header_subtag(header);
411   
412  switch(subtag) {
413  case subtag_simple_base_string:
414    add_char('"');
415    add_lisp_base_string(o);
416    add_char('"');
417    return;
418   
419  case subtag_bignum:
420    if (elements == 1) {
421      sprint_signed_decimal((signed_natural)(deref(o, 1)));
422      return;
423    }
424    if ((elements == 2) && (deref(o, 2) == 0)) {
425      sprint_unsigned_decimal(deref(o, 1));
426      return;
427    }
428    break;
429   
430  case subtag_double_float:
431    break;
432
433  case subtag_macptr:
434    add_c_string("#<MACPTR ");
435    sprint_unsigned_hex(deref(o,1));
436    add_c_string(">");
437    break;
438
439  default:
440    sprint_random_vector(o, subtag, elements);
441  }
442}
443
444void
445sprint_vector(LispObj o, int depth)
446{
447  LispObj header = header_of(o);
448 
449  if (immheader_tag_p(fulltag_of(header))) {
450    sprint_ivector(o);
451  } else {
452    sprint_gvector(o, depth);
453  }
454}
455
456void
457sprint_lisp_object(LispObj o, int depth) 
458{
459  if (--depth < 0) {
460    add_char('#');
461  } else {
462    switch (fulltag_of(o)) {
463    case fulltag_even_fixnum:
464    case fulltag_odd_fixnum:
465      sprint_signed_decimal(unbox_fixnum(o));
466      break;
467   
468#ifdef X8664
469    case fulltag_immheader_0:
470    case fulltag_immheader_1:
471    case fulltag_immheader_2:
472    case fulltag_nodeheader_0:
473    case fulltag_nodeheader_1:
474#else
475#endif     
476      add_c_string("#<header ? ");
477      sprint_unsigned_hex(o);
478      add_c_string(">");
479      break;
480
481#ifdef X8664
482    case fulltag_imm_0:
483    case fulltag_imm_1:
484#else
485#endif
486      if (o == unbound) {
487        add_c_string("#<Unbound>");
488      } else {
489        if (header_subtag(o) == subtag_character) {
490          unsigned c = (o >> charcode_shift);
491          add_c_string("#\\");
492          if ((c >= ' ') && (c < 0x7f)) {
493            add_char(c);
494          } else {
495            sprintf(numbuf, "%o", c);
496            add_c_string(numbuf);
497          }
498#ifdef X8664
499        } else if (header_subtag(o) == subtag_single_float) {
500          LispObj xx = o;
501          float f = ((float *)&xx)[1];
502          sprintf(numbuf, "%f", f);
503          add_c_string(numbuf);
504#endif
505        } else {
506
507          add_c_string("#<imm ");
508          sprint_unsigned_hex(o);
509          add_c_string(">");
510        }
511      }
512      break;
513   
514    case fulltag_nil:
515    case fulltag_cons:
516      sprint_list(o, depth);
517      break;
518     
519    case fulltag_misc:
520      sprint_vector(o, depth);
521      break;
522
523    case fulltag_symbol:
524      sprint_symbol(o);
525      break;
526
527    case fulltag_function:
528      sprint_function(o, depth);
529      break;
530
531    case fulltag_tra_0:
532    case fulltag_tra_1:
533      sprint_tra(o,depth);
534      break;
535    }
536  }
537}
538
539char *
540print_lisp_object(LispObj o)
541{
542  bufpos = 0;
543  if (setjmp(escape) == 0) {
544    sprint_lisp_object(o, 5);
545    printbuf[bufpos] = 0;
546  } else {
547    printbuf[PBUFLEN+0] = '.';
548    printbuf[PBUFLEN+1] = '.';
549    printbuf[PBUFLEN+2] = '.';
550    printbuf[PBUFLEN+3] = 0;
551  }
552  return printbuf;
553}
Note: See TracBrowser for help on using the repository browser.