source: release/1.9/source/lisp-kernel/ppc_print.c

Last change on this file was 14944, checked in by gb, 8 years ago

In all three versions of sprint_specializers_list(), try to print
EQL specializers sanely.
(May still want to do something to print ObjC class names.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.3 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        LispObj header = header_of(the_car);
140        unsigned subtag = header_subtag(header);
141
142        if (subtag == subtag_instance) {
143          if (unbox_fixnum(deref(the_car,1)) < (1<<20)) {
144            sprint_lisp_object(deref(deref(the_car,3), 4), depth);
145          } else {
146            /* An EQL specializer */
147            add_c_string("(EQL ");
148            sprint_lisp_object(deref(deref(the_car,3), 3), depth);
149            add_char(')');
150          }
151        } else {
152          sprint_lisp_object(the_car, depth);
153        }
154      } else {
155        sprint_lisp_object(the_car, depth);
156      }
157      the_cdr = cdr(o);
158      if (the_cdr != lisp_nil) {
159        add_char(' ');
160        if (fulltag_of(the_cdr) == fulltag_cons) {
161          o = the_cdr;
162          continue;
163        }
164        add_c_string(". ");
165        sprint_lisp_object(the_cdr, depth);
166        break;
167      }
168    }
169    break;
170  }
171  add_char(')');
172}
173
174char *
175vector_subtag_name(unsigned subtag)
176{
177  switch (subtag) {
178  case subtag_bit_vector:
179    return "BIT-VECTOR";
180    break;
181  case subtag_instance:
182    return "INSTANCE";
183    break;
184  case subtag_bignum:
185    return "BIGNUM";
186    break;
187  case subtag_u8_vector:
188    return "(UNSIGNED-BYTE 8)";
189    break;
190  case subtag_s8_vector:
191    return "(SIGNED-BYTE 8)";
192    break;
193  case subtag_u16_vector:
194    return "(UNSIGNED-BYTE 16)";
195    break;
196  case subtag_s16_vector:
197    return "(SIGNED-BYTE 16)";
198    break;
199  case subtag_u32_vector:
200    return "(UNSIGNED-BYTE 32)";
201    break;
202  case subtag_s32_vector:
203    return "(SIGNED-BYTE 32)";
204    break;
205#ifdef PPC64
206  case subtag_u64_vector:
207    return "(UNSIGNED-BYTE 64)";
208    break;
209  case subtag_s64_vector:
210    return "(SIGNED-BYTE 64)";
211    break;
212#endif
213  case subtag_package:
214    return "PACKAGE";
215    break;
216  case subtag_code_vector:
217    return "CODE-VECTOR";
218    break;
219  case subtag_slot_vector:
220    return "SLOT-VECTOR";
221    break;
222  default:
223    return "";
224    break;
225  }
226}
227
228
229void
230sprint_random_vector(LispObj o, unsigned subtag, natural elements)
231{
232  add_c_string("#<");
233  sprint_unsigned_decimal(elements);
234  add_c_string("-element vector subtag = ");
235  sprintf(numbuf, "%02X @", subtag);
236  add_c_string(numbuf);
237  sprint_unsigned_hex(o);
238  add_c_string(" (");
239  add_c_string(vector_subtag_name(subtag));
240  add_c_string(")>");
241}
242
243void
244sprint_symbol(LispObj o)
245{
246  lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o));
247  LispObj
248    pname = rawsym->pname,
249    package = rawsym->package_predicate;
250
251#ifdef PPC64
252  if (o == lisp_nil) {
253    add_c_string("()");
254    return;
255  }
256#endif
257  if (fulltag_of(package) == fulltag_cons) {
258    package = car(package);
259  }
260
261  if (package == nrs_KEYWORD_PACKAGE.vcell) {
262    add_char(':');
263  }
264  add_lisp_base_string(pname);
265}
266
267void
268sprint_function(LispObj o, int depth)
269{
270  LispObj lfbits, header, name = lisp_nil;
271  natural elements;
272
273  header = header_of(o);
274  elements = header_element_count(header);
275  lfbits = deref(o, elements);
276
277  if ((lfbits & lfbits_noname_mask) == 0) {
278    name = deref(o, elements-1);
279  }
280 
281  add_c_string("#<");
282  if (name == lisp_nil) {
283    add_c_string("Anonymous Function ");
284  } else {
285    if (lfbits & lfbits_method_mask) {
286      if (header_subtag(header_of(name)) == subtag_instance) {
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      } else {
305        sprint_lisp_object(name, depth);
306      }
307      add_char(' ');
308    } else {
309      add_c_string("Function ");
310      sprint_lisp_object(name, depth);
311      add_char(' ');
312    }
313  }
314  sprint_unsigned_hex(o);
315  add_char('>');
316}
317
318void
319sprint_gvector(LispObj o, int depth)
320{
321  LispObj header = header_of(o);
322  unsigned 
323    elements = header_element_count(header),
324    subtag = header_subtag(header);
325   
326  switch(subtag) {
327  case subtag_function:
328    sprint_function(o, depth);
329    break;
330   
331  case subtag_symbol:
332    sprint_symbol(o);
333    break;
334   
335  case subtag_struct:
336  case subtag_istruct:
337    add_c_string("#<");
338    sprint_lisp_object(deref(o,1), depth);
339    add_c_string(" @");
340    sprint_unsigned_hex(o);
341    add_c_string(">");
342    break;
343   
344  case subtag_simple_vector:
345    {
346      int i;
347      add_c_string("#(");
348      for(i = 1; i <= elements; i++) {
349        if (i > 1) {
350          add_char(' ');
351        }
352        sprint_lisp_object(deref(o, i), depth);
353      }
354      add_char(')');
355      break;
356    }
357     
358  default:
359    sprint_random_vector(o, subtag, elements);
360    break;
361  }
362}
363
364void
365sprint_ivector(LispObj o)
366{
367  LispObj header = header_of(o);
368  unsigned 
369    elements = header_element_count(header),
370    subtag = header_subtag(header);
371   
372  switch(subtag) {
373  case subtag_simple_base_string:
374    add_char('"');
375    add_lisp_base_string(o);
376    add_char('"');
377    return;
378   
379  case subtag_bignum:
380    if (elements == 1) {
381      sprint_signed_decimal((signed_natural)(deref(o, 1)));
382      return;
383    }
384    if ((elements == 2) && (deref(o, 2) == 0)) {
385      sprint_unsigned_decimal(deref(o, 1));
386      return;
387    }
388    break;
389   
390  case subtag_double_float:
391    break;
392
393  case subtag_macptr:
394    add_c_string("#<MACPTR ");
395    sprint_unsigned_hex(deref(o,1));
396    add_c_string(">");
397    break;
398
399  default:
400    sprint_random_vector(o, subtag, elements);
401  }
402}
403
404void
405sprint_vector(LispObj o, int depth)
406{
407  LispObj header = header_of(o);
408 
409  if (immheader_tag_p(fulltag_of(header))) {
410    sprint_ivector(o);
411  } else {
412    sprint_gvector(o, depth);
413  }
414}
415
416void
417sprint_lisp_object(LispObj o, int depth) 
418{
419  if (--depth < 0) {
420    add_char('#');
421  } else {
422    switch (fulltag_of(o)) {
423    case fulltag_even_fixnum:
424    case fulltag_odd_fixnum:
425      sprint_signed_decimal(unbox_fixnum(o));
426      break;
427   
428#ifdef PPC64
429    case fulltag_immheader_0:
430    case fulltag_immheader_1:
431    case fulltag_immheader_2:
432    case fulltag_immheader_3:
433    case fulltag_nodeheader_0:
434    case fulltag_nodeheader_1:
435    case fulltag_nodeheader_2:
436    case fulltag_nodeheader_3:
437#else
438    case fulltag_immheader:
439    case fulltag_nodeheader:
440#endif     
441      add_c_string("#<header ? ");
442      sprint_unsigned_hex(o);
443      add_c_string(">");
444      break;
445
446#ifdef PPC64
447    case fulltag_imm_0:
448    case fulltag_imm_1:
449    case fulltag_imm_2:
450    case fulltag_imm_3:
451#else
452    case fulltag_imm:
453#endif
454      if (o == unbound) {
455        add_c_string("#<Unbound>");
456      } else {
457        if (header_subtag(o) == subtag_character) {
458          unsigned c = (o >> charcode_shift);
459          add_c_string("#\\");
460          if ((c >= ' ') && (c < 0x7f)) {
461            add_char(c);
462          } else {
463            sprintf(numbuf, "%o", c);
464            add_c_string(numbuf);
465          }
466#ifdef PPC64
467        } else if (header_subtag(o) == subtag_single_float) {
468          sprintf(numbuf, "%f", o>>32);
469          add_c_string(numbuf);
470#endif
471        } else {
472
473          add_c_string("#<imm ");
474          sprint_unsigned_hex(o);
475          add_c_string(">");
476        }
477      }
478      break;
479   
480#ifndef PPC64
481    case fulltag_nil:
482#endif
483    case fulltag_cons:
484      sprint_list(o, depth);
485      break;
486     
487    case fulltag_misc:
488      sprint_vector(o, depth);
489      break;
490    }
491  }
492}
493
494char *
495print_lisp_object(LispObj o)
496{
497  bufpos = 0;
498  if (setjmp(escape) == 0) {
499    sprint_lisp_object(o, 5);
500    printbuf[bufpos] = 0;
501  } else {
502    printbuf[PBUFLEN+0] = '.';
503    printbuf[PBUFLEN+1] = '.';
504    printbuf[PBUFLEN+2] = '.';
505    printbuf[PBUFLEN+3] = 0;
506  }
507  return printbuf;
508}
Note: See TracBrowser for help on using the repository browser.