Mercurial > hg > xemacs-beta

comparison src/print.c @ 272:c5d627a313b1 r21-0b34

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b34
author cvs
date Mon, 13 Aug 2007 10:28:48 +0200
parents 677f6a0ee643
children 6330739388db
comparison
equal deleted inserted replaced
271:c7b7086b0a39 272:c5d627a313b1
34 #include "bytecode.h" 34 #include "bytecode.h"
35 #include "console-tty.h" 35 #include "console-tty.h"
36 #include "console-stream.h" 36 #include "console-stream.h"
37 #include "extents.h" 37 #include "extents.h"
38 #include "frame.h" 38 #include "frame.h"
39 #include "emacsfns.h"
40 #include "insdel.h" 39 #include "insdel.h"
41 #include "lstream.h" 40 #include "lstream.h"
41 #include "sysfile.h"
42 42
43 #endif /* not standalone */ 43 #endif /* not standalone */
44
45 #include <float.h>
46 /* Define if not in float.h */
47 #ifndef DBL_DIG
48 #define DBL_DIG 16
49 #endif
44 50
45 static void print_error_message (Lisp_Object data, Lisp_Object stream); 51 static void print_error_message (Lisp_Object data, Lisp_Object stream);
46 52
47 Lisp_Object Vstandard_output, Qstandard_output; 53 Lisp_Object Vstandard_output, Qstandard_output;
48 54
256 static Lisp_Object 262 static Lisp_Object
257 make_print_output_stream (FILE *file, Lisp_Object fun) 263 make_print_output_stream (FILE *file, Lisp_Object fun)
258 { 264 {
259 Lstream *str = Lstream_new (lstream_print, "w"); 265 Lstream *str = Lstream_new (lstream_print, "w");
260 struct print_stream *ps = get_print_stream (str); 266 struct print_stream *ps = get_print_stream (str);
261 Lisp_Object val = Qnil; 267 Lisp_Object val;
262 268
263 Lstream_set_character_mode (str); 269 Lstream_set_character_mode (str);
264 ps->file = file; 270 ps->file = file;
265 ps->fun = fun; 271 ps->fun = fun;
266 XSETLSTREAM (val, str); 272 XSETLSTREAM (val, str);
286 { 292 {
287 return get_print_stream (XLSTREAM (obj))->fun; 293 return get_print_stream (XLSTREAM (obj))->fun;
288 } 294 }
289 295
290 static int 296 static int
291 print_writer (Lstream *stream, CONST unsigned char *data, int size) 297 print_writer (Lstream *stream, CONST unsigned char *data, size_t size)
292 { 298 {
293 struct print_stream *ps = get_print_stream (stream); 299 struct print_stream *ps = get_print_stream (stream);
294 300
295 if (ps->file) 301 if (ps->file)
296 { 302 {
329 /* Emacs won't print whilst GCing, but an external debugger might */ 335 /* Emacs won't print whilst GCing, but an external debugger might */
330 if (gc_in_progress) 336 if (gc_in_progress)
331 return Qnil; 337 return Qnil;
332 338
333 printcharfun = canonicalize_printcharfun (printcharfun); 339 printcharfun = canonicalize_printcharfun (printcharfun);
334 if (EQ (printcharfun, Qnil)) 340 if (NILP (printcharfun))
335 { 341 {
336 stdio_stream = stdout; 342 stdio_stream = stdout;
337 } 343 }
338 #if 0 /* Don't bother */ 344 #if 0 /* Don't bother */
339 else if (SUBRP (indirect_function (printcharfun, 0)) 345 else if (SUBRP (indirect_function (printcharfun, 0))
473 { 479 {
474 /* This function can GC */ 480 /* This function can GC */
475 struct gcpro gcpro1; 481 struct gcpro gcpro1;
476 Lisp_Object name; 482 Lisp_Object name;
477 int speccount = specpdl_depth (); 483 int speccount = specpdl_depth ();
478 Lisp_Object buf, val; 484 Lisp_Object val;
479 485
480 #ifdef I18N3 486 #ifdef I18N3
481 /* #### should set the buffer to be translating. See print_internal(). */ 487 /* #### should set the buffer to be translating. See print_internal(). */
482 #endif 488 #endif
483 489
484 GCPRO1 (args); 490 GCPRO1 (args);
485 name = Feval (Fcar (args)); 491 name = Feval (XCAR (args));
486 UNGCPRO; 492 UNGCPRO;
487 493
488 CHECK_STRING (name); 494 CHECK_STRING (name);
489 temp_output_buffer_setup ((char *) XSTRING_DATA (name)); 495 temp_output_buffer_setup ((char *) XSTRING_DATA (name));
490 buf = Vstandard_output; 496
491 497 val = Fprogn (XCDR (args));
492 val = Fprogn (Fcdr (args)); 498
493 499 temp_output_buffer_show (Vstandard_output, Qnil);
494 temp_output_buffer_show (buf, Qnil);
495 500
496 return unbind_to (speccount, val); 501 return unbind_to (speccount, val);
497 } 502 }
498 #endif /* not standalone */ 503 #endif /* not standalone */
499 504
608 print_finish (the_stream); 613 print_finish (the_stream);
609 UNGCPRO; 614 UNGCPRO;
610 return obj; 615 return obj;
611 } 616 }
612 617
613 #include "emacsfns.h"
614 618
615 /* Synched with Emacs 19.34 -- underlying implementation (incarnated 619 /* Synched with Emacs 19.34 -- underlying implementation (incarnated
616 in print_error_message) is completely divergent, though. */ 620 in print_error_message) is completely divergent, though. */
617 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /* 621 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
618 Convert an error value (ERROR-SYMBOL . DATA) to an error message. 622 Convert an error value (ERROR-SYMBOL . DATA) to an error message.
906 print_internal (XCAR (obj), printcharfun, 910 print_internal (XCAR (obj), printcharfun,
907 escapeflag); 911 escapeflag);
908 obj = XCDR (obj); 912 obj = XCDR (obj);
909 } 913 }
910 } 914 }
911 if (!NILP (obj) && !CONSP (obj)) 915 if (!LISTP (obj))
912 { 916 {
913 write_c_string (" . ", printcharfun); 917 write_c_string (" . ", printcharfun);
914 print_internal (obj, printcharfun, escapeflag); 918 print_internal (obj, printcharfun, escapeflag);
915 } 919 }
916 UNGCPRO; 920 UNGCPRO;
1546 #if 1 1550 #if 1
1547 /* Debugging kludge -- unbuffered */ 1551 /* Debugging kludge -- unbuffered */
1548 static int debug_print_length = 50; 1552 static int debug_print_length = 50;
1549 static int debug_print_level = 15; 1553 static int debug_print_level = 15;
1550 Lisp_Object debug_temp; 1554 Lisp_Object debug_temp;
1551 void debug_print_no_newline (Lisp_Object debug_print_obj); 1555
1552 void 1556 static void
1553 debug_print_no_newline (Lisp_Object debug_print_obj) 1557 debug_print_no_newline (Lisp_Object debug_print_obj)
1554 { 1558 {
1555 /* This function can GC */ 1559 /* This function can GC */
1556 int old_print_readably = print_readably; 1560 int old_print_readably = print_readably;
1557 int old_print_depth = print_depth; 1561 int old_print_depth = print_depth;
1580 print_readably = old_print_readably; 1584 print_readably = old_print_readably;
1581 print_unbuffered--; 1585 print_unbuffered--;
1582 UNGCPRO; 1586 UNGCPRO;
1583 } 1587 }
1584 1588
1585 void debug_print (Lisp_Object debug_print_obj);
1586 void 1589 void
1587 debug_print (Lisp_Object debug_print_obj) 1590 debug_print (Lisp_Object debug_print_obj)
1588 { 1591 {
1589 debug_print_no_newline (debug_print_obj); 1592 debug_print_no_newline (debug_print_obj);
1590 stderr_out ("\r\n"); 1593 stderr_out ("\n");
1591 fflush (stderr); 1594 fflush (stderr);
1592 } 1595 }
1593 1596
1594 /* Debugging kludge -- unbuffered */ 1597 /* Debugging kludge -- unbuffered */
1598 /* This function provided for the benefit of the debugger. */
1599 void debug_backtrace (void);
1595 void 1600 void
1596 debug_backtrace (void) 1601 debug_backtrace (void)
1597 { 1602 {
1598 /* This function can GC */ 1603 /* This function can GC */
1599 int old_print_readably = print_readably; 1604 int old_print_readably = print_readably;