source: branches/arm/lisp-kernel/x86_print.c @ 13923

Last change on this file since 13923 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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