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

Last change on this file since 15267 was 14599, checked in by gb, 8 years ago

In the kernel debugger's printer, don't assume that a method-function's
name is an instance (the method object itself.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.9 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include <stdio.h>
19#include <stdarg.h>
20#include <setjmp.h>
21
22#include "lisp.h"
23#include "area.h"
24#include "lisp-exceptions.h"
25#include "lisp_globals.h"
26
27void
28sprint_lisp_object(LispObj, int);
29
30#define PBUFLEN 252
31
32char printbuf[PBUFLEN + 4];
33int bufpos = 0;
34
35jmp_buf escape;
36
37void
38add_char(char c)
39{
40  if (bufpos >= PBUFLEN) {
41    longjmp(escape, 1);
42  } else {
43    printbuf[bufpos++] = c;
44  }
45}
46
47void
48add_string(char *s, int len) 
49{
50  while(len--) {
51    add_char(*s++);
52  }
53}
54
55void
56add_lisp_base_string(LispObj str)
57{
58  lisp_char_code *src = (lisp_char_code *)  (ptr_from_lispobj(str + misc_data_offset));
59  natural i, n = header_element_count(header_of(str));
60
61  for (i=0; i < n; i++) {
62    add_char((char)(*src++));
63  }
64}
65
66void
67add_c_string(char *s)
68{
69  add_string(s, strlen(s));
70}
71
72char numbuf[64];
73
74void
75sprint_signed_decimal(signed_natural n)
76{
77  sprintf(numbuf, "%ld", n);
78  add_c_string(numbuf);
79}
80
81void
82sprint_unsigned_decimal(natural n)
83{
84  sprintf(numbuf, "%lu", n);
85  add_c_string(numbuf);
86}
87
88void
89sprint_unsigned_hex(natural n)
90{
91#ifdef PPC64
92  sprintf(numbuf, "#x%016lx", n);
93#else
94  sprintf(numbuf, "#x%08lx", n);
95#endif
96  add_c_string(numbuf);
97}
98
99void
100sprint_list(LispObj o, int depth)
101{
102  LispObj the_cdr;
103 
104  add_char('(');
105  while(1) {
106    if (o != lisp_nil) {
107      sprint_lisp_object(ptr_to_lispobj(car(o)), depth);
108      the_cdr = ptr_to_lispobj(cdr(o));
109      if (the_cdr != lisp_nil) {
110        add_char(' ');
111        if (fulltag_of(the_cdr) == fulltag_cons) {
112          o = the_cdr;
113          continue;
114        }
115        add_c_string(". ");
116        sprint_lisp_object(the_cdr, depth);
117        break;
118      }
119    }
120    break;
121  }
122  add_char(')');
123}
124
125/*
126  Print a list of method specializers, using the class name instead of the class object.
127*/
128
129void
130sprint_specializers_list(LispObj o, int depth)
131{
132  LispObj the_cdr, the_car;
133 
134  add_char('(');
135  while(1) {
136    if (o != lisp_nil) {
137      the_car = car(o);
138      if (fulltag_of(the_car) == fulltag_misc) {
139        sprint_lisp_object(deref(deref(the_car,3), 4), depth);
140      } else {
141        sprint_lisp_object(the_car, depth);
142      }
143      the_cdr = cdr(o);
144      if (the_cdr != lisp_nil) {
145        add_char(' ');
146        if (fulltag_of(the_cdr) == fulltag_cons) {
147          o = the_cdr;
148          continue;
149        }
150        add_c_string(". ");
151        sprint_lisp_object(the_cdr, depth);
152        break;
153      }
154    }
155    break;
156  }
157  add_char(')');
158}
159
160char *
161vector_subtag_name(unsigned subtag)
162{
163  switch (subtag) {
164  case subtag_bit_vector:
165    return "BIT-VECTOR";
166    break;
167  case subtag_instance:
168    return "INSTANCE";
169    break;
170  case subtag_bignum:
171    return "BIGNUM";
172    break;
173  case subtag_u8_vector:
174    return "(UNSIGNED-BYTE 8)";
175    break;
176  case subtag_s8_vector:
177    return "(SIGNED-BYTE 8)";
178    break;
179  case subtag_u16_vector:
180    return "(UNSIGNED-BYTE 16)";
181    break;
182  case subtag_s16_vector:
183    return "(SIGNED-BYTE 16)";
184    break;
185  case subtag_u32_vector:
186    return "(UNSIGNED-BYTE 32)";
187    break;
188  case subtag_s32_vector:
189    return "(SIGNED-BYTE 32)";
190    break;
191#ifdef PPC64
192  case subtag_u64_vector:
193    return "(UNSIGNED-BYTE 64)";
194    break;
195  case subtag_s64_vector:
196    return "(SIGNED-BYTE 64)";
197    break;
198#endif
199  case subtag_package:
200    return "PACKAGE";
201    break;
202  case subtag_code_vector:
203    return "CODE-VECTOR";
204    break;
205  case subtag_slot_vector:
206    return "SLOT-VECTOR";
207    break;
208  default:
209    return "";
210    break;
211  }
212}
213
214
215void
216sprint_random_vector(LispObj o, unsigned subtag, natural elements)
217{
218  add_c_string("#<");
219  sprint_unsigned_decimal(elements);
220  add_c_string("-element vector subtag = ");
221  sprintf(numbuf, "%02X @", subtag);
222  add_c_string(numbuf);
223  sprint_unsigned_hex(o);
224  add_c_string(" (");
225  add_c_string(vector_subtag_name(subtag));
226  add_c_string(")>");
227}
228
229void
230sprint_symbol(LispObj o)
231{
232  lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o));
233  LispObj
234    pname = rawsym->pname,
235    package = rawsym->package_predicate;
236
237#ifdef PPC64
238  if (o == lisp_nil) {
239    add_c_string("()");
240    return;
241  }
242#endif
243  if (fulltag_of(package) == fulltag_cons) {
244    package = car(package);
245  }
246
247  if (package == nrs_KEYWORD_PACKAGE.vcell) {
248    add_char(':');
249  }
250  add_lisp_base_string(pname);
251}
252
253void
254sprint_function(LispObj o, int depth)
255{
256  LispObj lfbits, header, name = lisp_nil;
257  natural elements;
258
259  header = header_of(o);
260  elements = header_element_count(header);
261  lfbits = deref(o, elements);
262
263  if ((lfbits & lfbits_noname_mask) == 0) {
264    name = deref(o, elements-1);
265  }
266 
267  add_c_string("#<");
268  if (name == lisp_nil) {
269    add_c_string("Anonymous Function ");
270  } else {
271    if (lfbits & lfbits_method_mask) {
272      if (header_subtag(header_of(name)) == subtag_instance) {
273        LispObj
274          slot_vector = deref(name,3),
275          method_name = deref(slot_vector, 6),
276          method_qualifiers = deref(slot_vector, 2),
277          method_specializers = deref(slot_vector, 3);
278        add_c_string("Method-Function ");
279        sprint_lisp_object(method_name, depth);
280        add_char(' ');
281        if (method_qualifiers != lisp_nil) {
282          if (cdr(method_qualifiers) == lisp_nil) {
283            sprint_lisp_object(car(method_qualifiers), depth);
284          } else {
285            sprint_lisp_object(method_qualifiers, depth);
286          }
287          add_char(' ');
288        }
289        sprint_specializers_list(method_specializers, depth);
290      } else {
291        sprint_lisp_object(name, depth);
292      }
293      add_char(' ');
294    } else {
295      add_c_string("Function ");
296      sprint_lisp_object(name, depth);
297      add_char(' ');
298    }
299  }
300  sprint_unsigned_hex(o);
301  add_char('>');
302}
303
304void
305sprint_gvector(LispObj o, int depth)
306{
307  LispObj header = header_of(o);
308  unsigned 
309    elements = header_element_count(header),
310    subtag = header_subtag(header);
311   
312  switch(subtag) {
313  case subtag_function:
314    sprint_function(o, depth);
315    break;
316   
317  case subtag_symbol:
318    sprint_symbol(o);
319    break;
320   
321  case subtag_struct:
322  case subtag_istruct:
323    add_c_string("#<");
324    sprint_lisp_object(deref(o,1), depth);
325    add_c_string(" @");
326    sprint_unsigned_hex(o);
327    add_c_string(">");
328    break;
329   
330  case subtag_simple_vector:
331    {
332      int i;
333      add_c_string("#(");
334      for(i = 1; i <= elements; i++) {
335        if (i > 1) {
336          add_char(' ');
337        }
338        sprint_lisp_object(deref(o, i), depth);
339      }
340      add_char(')');
341      break;
342    }
343     
344  default:
345    sprint_random_vector(o, subtag, elements);
346    break;
347  }
348}
349
350void
351sprint_ivector(LispObj o)
352{
353  LispObj header = header_of(o);
354  unsigned 
355    elements = header_element_count(header),
356    subtag = header_subtag(header);
357   
358  switch(subtag) {
359  case subtag_simple_base_string:
360    add_char('"');
361    add_lisp_base_string(o);
362    add_char('"');
363    return;
364   
365  case subtag_bignum:
366    if (elements == 1) {
367      sprint_signed_decimal((signed_natural)(deref(o, 1)));
368      return;
369    }
370    if ((elements == 2) && (deref(o, 2) == 0)) {
371      sprint_unsigned_decimal(deref(o, 1));
372      return;
373    }
374    break;
375   
376  case subtag_double_float:
377    break;
378
379  case subtag_macptr:
380    add_c_string("#<MACPTR ");
381    sprint_unsigned_hex(deref(o,1));
382    add_c_string(">");
383    break;
384
385  default:
386    sprint_random_vector(o, subtag, elements);
387  }
388}
389
390void
391sprint_vector(LispObj o, int depth)
392{
393  LispObj header = header_of(o);
394 
395  if (immheader_tag_p(fulltag_of(header))) {
396    sprint_ivector(o);
397  } else {
398    sprint_gvector(o, depth);
399  }
400}
401
402void
403sprint_lisp_object(LispObj o, int depth) 
404{
405  if (--depth < 0) {
406    add_char('#');
407  } else {
408    switch (fulltag_of(o)) {
409    case fulltag_even_fixnum:
410    case fulltag_odd_fixnum:
411      sprint_signed_decimal(unbox_fixnum(o));
412      break;
413   
414#ifdef PPC64
415    case fulltag_immheader_0:
416    case fulltag_immheader_1:
417    case fulltag_immheader_2:
418    case fulltag_immheader_3:
419    case fulltag_nodeheader_0:
420    case fulltag_nodeheader_1:
421    case fulltag_nodeheader_2:
422    case fulltag_nodeheader_3:
423#else
424    case fulltag_immheader:
425    case fulltag_nodeheader:
426#endif     
427      add_c_string("#<header ? ");
428      sprint_unsigned_hex(o);
429      add_c_string(">");
430      break;
431
432#ifdef PPC64
433    case fulltag_imm_0:
434    case fulltag_imm_1:
435    case fulltag_imm_2:
436    case fulltag_imm_3:
437#else
438    case fulltag_imm:
439#endif
440      if (o == unbound) {
441        add_c_string("#<Unbound>");
442      } else {
443        if (header_subtag(o) == subtag_character) {
444          unsigned c = (o >> charcode_shift);
445          add_c_string("#\\");
446          if ((c >= ' ') && (c < 0x7f)) {
447            add_char(c);
448          } else {
449            sprintf(numbuf, "%o", c);
450            add_c_string(numbuf);
451          }
452#ifdef PPC64
453        } else if (header_subtag(o) == subtag_single_float) {
454          sprintf(numbuf, "%f", o>>32);
455          add_c_string(numbuf);
456#endif
457        } else {
458
459          add_c_string("#<imm ");
460          sprint_unsigned_hex(o);
461          add_c_string(">");
462        }
463      }
464      break;
465   
466#ifndef PPC64
467    case fulltag_nil:
468#endif
469    case fulltag_cons:
470      sprint_list(o, depth);
471      break;
472     
473    case fulltag_misc:
474      sprint_vector(o, depth);
475      break;
476    }
477  }
478}
479
480char *
481print_lisp_object(LispObj o)
482{
483  bufpos = 0;
484  if (setjmp(escape) == 0) {
485    sprint_lisp_object(o, 5);
486    printbuf[bufpos] = 0;
487  } else {
488    printbuf[PBUFLEN+0] = '.';
489    printbuf[PBUFLEN+1] = '.';
490    printbuf[PBUFLEN+2] = '.';
491    printbuf[PBUFLEN+3] = 0;
492  }
493  return printbuf;
494}
Note: See TracBrowser for help on using the repository browser.