source: trunk/source/lisp-kernel/ppc_print.c @ 14347

Last change on this file since 14347 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: 9.7 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      LispObj
273        slot_vector = deref(name,3),
274        method_name = deref(slot_vector, 6),
275        method_qualifiers = deref(slot_vector, 2),
276        method_specializers = deref(slot_vector, 3);
277      add_c_string("Method-Function ");
278      sprint_lisp_object(method_name, depth);
279      add_char(' ');
280      if (method_qualifiers != lisp_nil) {
281        if (cdr(method_qualifiers) == lisp_nil) {
282          sprint_lisp_object(car(method_qualifiers), depth);
283        } else {
284          sprint_lisp_object(method_qualifiers, depth);
285        }
286        add_char(' ');
287      }
288      sprint_specializers_list(method_specializers, depth);
289      add_char(' ');
290    } else {
291      add_c_string("Function ");
292      sprint_lisp_object(name, depth);
293      add_char(' ');
294    }
295  }
296  sprint_unsigned_hex(o);
297  add_char('>');
298}
299
300void
301sprint_gvector(LispObj o, int depth)
302{
303  LispObj header = header_of(o);
304  unsigned 
305    elements = header_element_count(header),
306    subtag = header_subtag(header);
307   
308  switch(subtag) {
309  case subtag_function:
310    sprint_function(o, depth);
311    break;
312   
313  case subtag_symbol:
314    sprint_symbol(o);
315    break;
316   
317  case subtag_struct:
318  case subtag_istruct:
319    add_c_string("#<");
320    sprint_lisp_object(deref(o,1), depth);
321    add_c_string(" @");
322    sprint_unsigned_hex(o);
323    add_c_string(">");
324    break;
325   
326  case subtag_simple_vector:
327    {
328      int i;
329      add_c_string("#(");
330      for(i = 1; i <= elements; i++) {
331        if (i > 1) {
332          add_char(' ');
333        }
334        sprint_lisp_object(deref(o, i), depth);
335      }
336      add_char(')');
337      break;
338    }
339     
340  default:
341    sprint_random_vector(o, subtag, elements);
342    break;
343  }
344}
345
346void
347sprint_ivector(LispObj o)
348{
349  LispObj header = header_of(o);
350  unsigned 
351    elements = header_element_count(header),
352    subtag = header_subtag(header);
353   
354  switch(subtag) {
355  case subtag_simple_base_string:
356    add_char('"');
357    add_lisp_base_string(o);
358    add_char('"');
359    return;
360   
361  case subtag_bignum:
362    if (elements == 1) {
363      sprint_signed_decimal((signed_natural)(deref(o, 1)));
364      return;
365    }
366    if ((elements == 2) && (deref(o, 2) == 0)) {
367      sprint_unsigned_decimal(deref(o, 1));
368      return;
369    }
370    break;
371   
372  case subtag_double_float:
373    break;
374
375  case subtag_macptr:
376    add_c_string("#<MACPTR ");
377    sprint_unsigned_hex(deref(o,1));
378    add_c_string(">");
379    break;
380
381  default:
382    sprint_random_vector(o, subtag, elements);
383  }
384}
385
386void
387sprint_vector(LispObj o, int depth)
388{
389  LispObj header = header_of(o);
390 
391  if (immheader_tag_p(fulltag_of(header))) {
392    sprint_ivector(o);
393  } else {
394    sprint_gvector(o, depth);
395  }
396}
397
398void
399sprint_lisp_object(LispObj o, int depth) 
400{
401  if (--depth < 0) {
402    add_char('#');
403  } else {
404    switch (fulltag_of(o)) {
405    case fulltag_even_fixnum:
406    case fulltag_odd_fixnum:
407      sprint_signed_decimal(unbox_fixnum(o));
408      break;
409   
410#ifdef PPC64
411    case fulltag_immheader_0:
412    case fulltag_immheader_1:
413    case fulltag_immheader_2:
414    case fulltag_immheader_3:
415    case fulltag_nodeheader_0:
416    case fulltag_nodeheader_1:
417    case fulltag_nodeheader_2:
418    case fulltag_nodeheader_3:
419#else
420    case fulltag_immheader:
421    case fulltag_nodeheader:
422#endif     
423      add_c_string("#<header ? ");
424      sprint_unsigned_hex(o);
425      add_c_string(">");
426      break;
427
428#ifdef PPC64
429    case fulltag_imm_0:
430    case fulltag_imm_1:
431    case fulltag_imm_2:
432    case fulltag_imm_3:
433#else
434    case fulltag_imm:
435#endif
436      if (o == unbound) {
437        add_c_string("#<Unbound>");
438      } else {
439        if (header_subtag(o) == subtag_character) {
440          unsigned c = (o >> charcode_shift);
441          add_c_string("#\\");
442          if ((c >= ' ') && (c < 0x7f)) {
443            add_char(c);
444          } else {
445            sprintf(numbuf, "%o", c);
446            add_c_string(numbuf);
447          }
448#ifdef PPC64
449        } else if (header_subtag(o) == subtag_single_float) {
450          sprintf(numbuf, "%f", o>>32);
451          add_c_string(numbuf);
452#endif
453        } else {
454
455          add_c_string("#<imm ");
456          sprint_unsigned_hex(o);
457          add_c_string(">");
458        }
459      }
460      break;
461   
462#ifndef PPC64
463    case fulltag_nil:
464#endif
465    case fulltag_cons:
466      sprint_list(o, depth);
467      break;
468     
469    case fulltag_misc:
470      sprint_vector(o, depth);
471      break;
472    }
473  }
474}
475
476char *
477print_lisp_object(LispObj o)
478{
479  bufpos = 0;
480  if (setjmp(escape) == 0) {
481    sprint_lisp_object(o, 5);
482    printbuf[bufpos] = 0;
483  } else {
484    printbuf[PBUFLEN+0] = '.';
485    printbuf[PBUFLEN+1] = '.';
486    printbuf[PBUFLEN+2] = '.';
487    printbuf[PBUFLEN+3] = 0;
488  }
489  return printbuf;
490}
Note: See TracBrowser for help on using the repository browser.