1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
20
21
22 #include <config.h>
23 #include <stdio.h>
24 #include <setjmp.h>
25 #include "lisp.h"
26 #include "buffer.h"
27 #include "character.h"
28 #include "charset.h"
29 #include "keyboard.h"
30 #include "frame.h"
31 #include "window.h"
32 #include "process.h"
33 #include "dispextern.h"
34 #include "termchar.h"
35 #include "intervals.h"
36 #include "blockinput.h"
37 #include "termhooks.h"
38 #include "font.h"
39
40 Lisp_Object Vstandard_output, Qstandard_output;
41
42 Lisp_Object Qtemp_buffer_setup_hook;
43
44
45 extern Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
46
47 Lisp_Object Vfloat_output_format, Qfloat_output_format;
48
49 #include <math.h>
50
51 #if STDC_HEADERS
52 #include <float.h>
53 #endif
54
55
56 #ifndef FLT_RADIX
57 #define FLT_RADIX 2
58 #endif
59 #ifndef DBL_MANT_DIG
60 #define DBL_MANT_DIG 53
61 #endif
62 #ifndef DBL_DIG
63 #define DBL_DIG 15
64 #endif
65 #ifndef DBL_MIN
66 #define DBL_MIN 2.2250738585072014e-308
67 #endif
68
69 #ifdef DBL_MIN_REPLACEMENT
70 #undef DBL_MIN
71 #define DBL_MIN DBL_MIN_REPLACEMENT
72 #endif
73
74 75 76 77 78
79 #if FLT_RADIX == 2 && DBL_MANT_DIG == 53
80 #define DOUBLE_DIGITS_BOUND 17
81 #else
82 #define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG))))
83 #endif
84
85
86 int print_depth;
87
88
89 int new_backquote_output;
90
91
92 #define PRINT_CIRCLE 200
93 Lisp_Object being_printed[PRINT_CIRCLE];
94
95 96
97 char *print_buffer;
98
99
100 int print_buffer_size;
101
102 int print_buffer_pos;
103
104 int print_buffer_pos_byte;
105
106 107
108
109 Lisp_Object Vprint_length;
110
111 112
113
114 Lisp_Object Vprint_level;
115
116
117
118 int print_escape_newlines;
119
120 121
122
123 int print_escape_nonascii;
124
125
126
127 int print_escape_multibyte;
128
129 Lisp_Object Qprint_escape_newlines;
130 Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;
131
132
133
134 int print_quoted;
135
136
137
138 Lisp_Object Vprint_gensym;
139
140
141
142 Lisp_Object Vprint_circle;
143
144 145
146
147 Lisp_Object Vprint_continuous_numbering;
148
149 150 151 152 153 154
155 int print_number_index;
156 Lisp_Object Vprint_number_table;
157
158 159 160
161 #define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2]
162 #define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1]
163
164 165
166
167 extern int noninteractive_need_newline;
168
169 extern int minibuffer_auto_raise;
170
171 void print_interval ();
172
173
174 int print_output_debug_flag = 1;
175
176
177
178
179 180 181 182 183 184
185
186 #define PRINTDECLARE \
187 struct buffer *old = current_buffer; \
188 int old_point = -1, start_point = -1; \
189 int old_point_byte = -1, start_point_byte = -1; \
190 int specpdl_count = SPECPDL_INDEX (); \
191 int free_print_buffer = 0; \
192 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \
193 Lisp_Object original
194
195 #define PRINTPREPARE \
196 original = printcharfun; \
197 if (NILP (printcharfun)) printcharfun = Qt; \
198 if (BUFFERP (printcharfun)) \
199 { \
200 if (XBUFFER (printcharfun) != current_buffer) \
201 Fset_buffer (printcharfun); \
202 printcharfun = Qnil; \
203 } \
204 if (MARKERP (printcharfun)) \
205 { \
206 EMACS_INT marker_pos; \
207 if (! XMARKER (printcharfun)->buffer) \
208 error ("Marker does not point anywhere"); \
209 if (XMARKER (printcharfun)->buffer != current_buffer) \
210 set_buffer_internal (XMARKER (printcharfun)->buffer); \
211 marker_pos = marker_position (printcharfun); \
212 if (marker_pos < BEGV || marker_pos > ZV) \
213 error ("Marker is outside the accessible part of the buffer"); \
214 old_point = PT; \
215 old_point_byte = PT_BYTE; \
216 SET_PT_BOTH (marker_pos, \
217 marker_byte_position (printcharfun)); \
218 start_point = PT; \
219 start_point_byte = PT_BYTE; \
220 printcharfun = Qnil; \
221 } \
222 if (NILP (printcharfun)) \
223 { \
224 Lisp_Object string; \
225 if (NILP (current_buffer->enable_multibyte_characters) \
226 && ! print_escape_multibyte) \
227 specbind (Qprint_escape_multibyte, Qt); \
228 if (! NILP (current_buffer->enable_multibyte_characters) \
229 && ! print_escape_nonascii) \
230 specbind (Qprint_escape_nonascii, Qt); \
231 if (print_buffer != 0) \
232 { \
233 string = make_string_from_bytes (print_buffer, \
234 print_buffer_pos, \
235 print_buffer_pos_byte); \
236 record_unwind_protect (print_unwind, string); \
237 } \
238 else \
239 { \
240 print_buffer_size = 1000; \
241 print_buffer = (char *) xmalloc (print_buffer_size); \
242 free_print_buffer = 1; \
243 } \
244 print_buffer_pos = 0; \
245 print_buffer_pos_byte = 0; \
246 } \
247 if (EQ (printcharfun, Qt) && ! noninteractive) \
248 setup_echo_area_for_printing (multibyte);
249
250 #define PRINTFINISH \
251 if (NILP (printcharfun)) \
252 { \
253 if (print_buffer_pos != print_buffer_pos_byte \
254 && NILP (current_buffer->enable_multibyte_characters)) \
255 { \
256 unsigned char *temp \
257 = (unsigned char *) alloca (print_buffer_pos + 1); \
258 copy_text (print_buffer, temp, print_buffer_pos_byte, \
259 1, 0); \
260 insert_1_both (temp, print_buffer_pos, \
261 print_buffer_pos, 0, 1, 0); \
262 } \
263 else \
264 insert_1_both (print_buffer, print_buffer_pos, \
265 print_buffer_pos_byte, 0, 1, 0); \
266 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
267 } \
268 if (free_print_buffer) \
269 { \
270 xfree (print_buffer); \
271 print_buffer = 0; \
272 } \
273 unbind_to (specpdl_count, Qnil); \
274 if (MARKERP (original)) \
275 set_marker_both (original, Qnil, PT, PT_BYTE); \
276 if (old_point >= 0) \
277 SET_PT_BOTH (old_point + (old_point >= start_point \
278 ? PT - start_point : 0), \
279 old_point_byte + (old_point_byte >= start_point_byte \
280 ? PT_BYTE - start_point_byte : 0)); \
281 if (old != current_buffer) \
282 set_buffer_internal (old);
283
284 #define PRINTCHAR(ch) printchar (ch, printcharfun)
285
286 287
288
289 static Lisp_Object
290 print_unwind (saved_text)
291 Lisp_Object saved_text;
292 {
293 bcopy (SDATA (saved_text), print_buffer, SCHARS (saved_text));
294 return Qnil;
295 }
296
297
298 299 300 301
302
303 static void
304 printchar (ch, fun)
305 unsigned int ch;
306 Lisp_Object fun;
307 {
308 if (!NILP (fun) && !EQ (fun, Qt))
309 call1 (fun, make_number (ch));
310 else
311 {
312 unsigned char str[MAX_MULTIBYTE_LENGTH];
313 int len = CHAR_STRING (ch, str);
314
315 QUIT;
316
317 if (NILP (fun))
318 {
319 if (print_buffer_pos_byte + len >= print_buffer_size)
320 print_buffer = (char *) xrealloc (print_buffer,
321 print_buffer_size *= 2);
322 bcopy (str, print_buffer + print_buffer_pos_byte, len);
323 print_buffer_pos += 1;
324 print_buffer_pos_byte += len;
325 }
326 else if (noninteractive)
327 {
328 fwrite (str, 1, len, stdout);
329 noninteractive_need_newline = 1;
330 }
331 else
332 {
333 int multibyte_p
334 = !NILP (current_buffer->enable_multibyte_characters);
335
336 setup_echo_area_for_printing (multibyte_p);
337 insert_char (ch);
338 message_dolog (str, len, 0, multibyte_p);
339 }
340 }
341 }
342
343
344 345 346 347 348 349 350 351 352 353
354
355 static void
356 strout (ptr, size, size_byte, printcharfun, multibyte)
357 char *ptr;
358 int size, size_byte;
359 Lisp_Object printcharfun;
360 int multibyte;
361 {
362 if (size < 0)
363 size_byte = size = strlen (ptr);
364
365 if (NILP (printcharfun))
366 {
367 if (print_buffer_pos_byte + size_byte > print_buffer_size)
368 {
369 print_buffer_size = print_buffer_size * 2 + size_byte;
370 print_buffer = (char *) xrealloc (print_buffer,
371 print_buffer_size);
372 }
373 bcopy (ptr, print_buffer + print_buffer_pos_byte, size_byte);
374 print_buffer_pos += size;
375 print_buffer_pos_byte += size_byte;
376 }
377 else if (noninteractive && EQ (printcharfun, Qt))
378 {
379 fwrite (ptr, 1, size_byte, stdout);
380 noninteractive_need_newline = 1;
381 }
382 else if (EQ (printcharfun, Qt))
383 {
384 385 386
387 int i;
388 int multibyte_p
389 = !NILP (current_buffer->enable_multibyte_characters);
390
391 setup_echo_area_for_printing (multibyte_p);
392 message_dolog (ptr, size_byte, 0, multibyte_p);
393
394 if (size == size_byte)
395 {
396 for (i = 0; i < size; ++i)
397 insert_char ((unsigned char) *ptr++);
398 }
399 else
400 {
401 int len;
402 for (i = 0; i < size_byte; i += len)
403 {
404 int ch = STRING_CHAR_AND_LENGTH (ptr + i, len);
405 insert_char (ch);
406 }
407 }
408 }
409 else
410 {
411
412 int i = 0;
413
414 if (size == size_byte)
415 {
416 while (i < size_byte)
417 {
418 int ch = ptr[i++];
419 PRINTCHAR (ch);
420 }
421 }
422 else
423 {
424 while (i < size_byte)
425 {
426 427 428
429 int len;
430 int ch = STRING_CHAR_AND_LENGTH (ptr + i, len);
431 PRINTCHAR (ch);
432 i += len;
433 }
434 }
435 }
436 }
437
438 439 440
441
442 static void
443 print_string (string, printcharfun)
444 Lisp_Object string;
445 Lisp_Object printcharfun;
446 {
447 if (EQ (printcharfun, Qt) || NILP (printcharfun))
448 {
449 int chars;
450
451 if (print_escape_nonascii)
452 string = string_escape_byte8 (string);
453
454 if (STRING_MULTIBYTE (string))
455 chars = SCHARS (string);
456 else if (! print_escape_nonascii
457 && (EQ (printcharfun, Qt)
458 ? ! NILP (buffer_defaults.enable_multibyte_characters)
459 : ! NILP (current_buffer->enable_multibyte_characters)))
460 {
461 462 463
464 Lisp_Object newstr;
465 int bytes;
466
467 chars = SBYTES (string);
468 bytes = parse_str_to_multibyte (SDATA (string), chars);
469 if (chars < bytes)
470 {
471 newstr = make_uninit_multibyte_string (chars, bytes);
472 bcopy (SDATA (string), SDATA (newstr), chars);
473 str_to_multibyte (SDATA (newstr), bytes, chars);
474 string = newstr;
475 }
476 }
477 else
478 chars = SBYTES (string);
479
480 if (EQ (printcharfun, Qt))
481 {
482
483 int nbytes = SBYTES (string);
484 char *buffer;
485
486 487
488 USE_SAFE_ALLOCA;
489
490 SAFE_ALLOCA (buffer, char *, nbytes);
491 bcopy (SDATA (string), buffer, nbytes);
492
493 strout (buffer, chars, SBYTES (string),
494 printcharfun, STRING_MULTIBYTE (string));
495
496 SAFE_FREE ();
497 }
498 else
499
500 strout (SDATA (string),
501 chars, SBYTES (string),
502 printcharfun, STRING_MULTIBYTE (string));
503 }
504 else
505 {
506 507
508 int i;
509 int size = SCHARS (string);
510 int size_byte = SBYTES (string);
511 struct gcpro gcpro1;
512 GCPRO1 (string);
513 if (size == size_byte)
514 for (i = 0; i < size; i++)
515 PRINTCHAR (SREF (string, i));
516 else
517 for (i = 0; i < size_byte; )
518 {
519 520
521 int len;
522 int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
523 PRINTCHAR (ch);
524 i += len;
525 }
526 UNGCPRO;
527 }
528 }
529
530 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
531 doc: 532 )
533 (character, printcharfun)
534 Lisp_Object character, printcharfun;
535 {
536 PRINTDECLARE;
537
538 if (NILP (printcharfun))
539 printcharfun = Vstandard_output;
540 CHECK_NUMBER (character);
541 PRINTPREPARE;
542 PRINTCHAR (XINT (character));
543 PRINTFINISH;
544 return character;
545 }
546
547 548 549
550
551 void
552 write_string (data, size)
553 char *data;
554 int size;
555 {
556 PRINTDECLARE;
557 Lisp_Object printcharfun;
558
559 printcharfun = Vstandard_output;
560
561 PRINTPREPARE;
562 strout (data, size, size, printcharfun, 0);
563 PRINTFINISH;
564 }
565
566 567 568
569
570 void
571 write_string_1 (data, size, printcharfun)
572 char *data;
573 int size;
574 Lisp_Object printcharfun;
575 {
576 PRINTDECLARE;
577
578 PRINTPREPARE;
579 strout (data, size, size, printcharfun, 0);
580 PRINTFINISH;
581 }
582
583
584 void
585 temp_output_buffer_setup (bufname)
586 const char *bufname;
587 {
588 int count = SPECPDL_INDEX ();
589 register struct buffer *old = current_buffer;
590 register Lisp_Object buf;
591
592 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
593
594 Fset_buffer (Fget_buffer_create (build_string (bufname)));
595
596 Fkill_all_local_variables ();
597 delete_all_overlays (current_buffer);
598 current_buffer->directory = old->directory;
599 current_buffer->read_only = Qnil;
600 current_buffer->filename = Qnil;
601 current_buffer->undo_list = Qt;
602 eassert (current_buffer->overlays_before == NULL);
603 eassert (current_buffer->overlays_after == NULL);
604 current_buffer->enable_multibyte_characters
605 = buffer_defaults.enable_multibyte_characters;
606 specbind (Qinhibit_read_only, Qt);
607 specbind (Qinhibit_modification_hooks, Qt);
608 Ferase_buffer ();
609 XSETBUFFER (buf, current_buffer);
610
611 Frun_hooks (1, &Qtemp_buffer_setup_hook);
612
613 unbind_to (count, Qnil);
614
615 specbind (Qstandard_output, buf);
616 }
617
618 Lisp_Object
619 internal_with_output_to_temp_buffer (bufname, function, args)
620 const char *bufname;
621 Lisp_Object (*function) P_ ((Lisp_Object));
622 Lisp_Object args;
623 {
624 int count = SPECPDL_INDEX ();
625 Lisp_Object buf, val;
626 struct gcpro gcpro1;
627
628 GCPRO1 (args);
629 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
630 temp_output_buffer_setup (bufname);
631 buf = Vstandard_output;
632 UNGCPRO;
633
634 val = (*function) (args);
635
636 GCPRO1 (val);
637 temp_output_buffer_show (buf);
638 UNGCPRO;
639
640 return unbind_to (count, val);
641 }
642
643 DEFUN ("with-output-to-temp-buffer",
644 Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
645 1, UNEVALLED, 0,
646 doc: 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 )
673 (args)
674 Lisp_Object args;
675 {
676 struct gcpro gcpro1;
677 Lisp_Object name;
678 int count = SPECPDL_INDEX ();
679 Lisp_Object buf, val;
680
681 GCPRO1(args);
682 name = Feval (Fcar (args));
683 CHECK_STRING (name);
684 temp_output_buffer_setup (SDATA (name));
685 buf = Vstandard_output;
686 UNGCPRO;
687
688 val = Fprogn (XCDR (args));
689
690 GCPRO1 (val);
691 temp_output_buffer_show (buf);
692 UNGCPRO;
693
694 return unbind_to (count, val);
695 }
696
697
698 static void print ();
699 static void print_preprocess ();
700 static void print_preprocess_string ();
701 static void print_object ();
702
703 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
704 doc: 705 )
706 (printcharfun)
707 Lisp_Object printcharfun;
708 {
709 PRINTDECLARE;
710
711 if (NILP (printcharfun))
712 printcharfun = Vstandard_output;
713 PRINTPREPARE;
714 PRINTCHAR ('\n');
715 PRINTFINISH;
716 return Qt;
717 }
718
719 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
720 doc: 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 )
742 (object, printcharfun)
743 Lisp_Object object, printcharfun;
744 {
745 PRINTDECLARE;
746
747 if (NILP (printcharfun))
748 printcharfun = Vstandard_output;
749 PRINTPREPARE;
750 print (object, printcharfun, 1);
751 PRINTFINISH;
752 return object;
753 }
754
755
756 Lisp_Object Vprin1_to_string_buffer;
757
758 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
759 doc: 760 761 762 763 764 765 766 767 768 )
769 (object, noescape)
770 Lisp_Object object, noescape;
771 {
772 Lisp_Object printcharfun;
773
774 Lisp_Object save_deactivate_mark;
775 int count = SPECPDL_INDEX ();
776 struct buffer *previous;
777
778 specbind (Qinhibit_modification_hooks, Qt);
779
780 {
781 PRINTDECLARE;
782
783 784 785
786 save_deactivate_mark = Vdeactivate_mark;
787
788 abort_on_gc++;
789
790 printcharfun = Vprin1_to_string_buffer;
791 PRINTPREPARE;
792 print (object, printcharfun, NILP (noescape));
793
794 PRINTFINISH;
795 }
796
797 previous = current_buffer;
798 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
799 object = Fbuffer_string ();
800 if (SBYTES (object) == SCHARS (object))
801 STRING_SET_UNIBYTE (object);
802
803 804 805
806 Ferase_buffer ();
807 set_buffer_internal (previous);
808
809 Vdeactivate_mark = save_deactivate_mark;
810
811
812 abort_on_gc--;
813 return unbind_to (count, object);
814 }
815
816 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
817 doc: 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 )
838 (object, printcharfun)
839 Lisp_Object object, printcharfun;
840 {
841 PRINTDECLARE;
842
843 if (NILP (printcharfun))
844 printcharfun = Vstandard_output;
845 PRINTPREPARE;
846 print (object, printcharfun, 0);
847 PRINTFINISH;
848 return object;
849 }
850
851 DEFUN ("print", Fprint, Sprint, 1, 2, 0,
852 doc: 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 )
874 (object, printcharfun)
875 Lisp_Object object, printcharfun;
876 {
877 PRINTDECLARE;
878 struct gcpro gcpro1;
879
880 if (NILP (printcharfun))
881 printcharfun = Vstandard_output;
882 GCPRO1 (object);
883 PRINTPREPARE;
884 PRINTCHAR ('\n');
885 print (object, printcharfun, 1);
886 PRINTCHAR ('\n');
887 PRINTFINISH;
888 UNGCPRO;
889 return object;
890 }
891
892 893
894 Lisp_Object Qexternal_debugging_output;
895
896 DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
897 doc: 898 899 )
900 (character)
901 Lisp_Object character;
902 {
903 CHECK_NUMBER (character);
904 putc (XINT (character), stderr);
905
906 #ifdef WINDOWSNT
907
908 if (print_output_debug_flag)
909 {
910 char buf[2] = {(char) XINT (character), '\0'};
911 OutputDebugString (buf);
912 }
913 #endif
914
915 return character;
916 }
917
918 919
920
921 void
922 debug_output_compilation_hack (x)
923 int x;
924 {
925 print_output_debug_flag = x;
926 }
927
928 #if defined (GNU_LINUX)
929
930 931
932
933 #define WITH_REDIRECT_DEBUGGING_OUTPUT 1
934
935 FILE *initial_stderr_stream = NULL;
936
937 DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output,
938 1, 2,
939 "FDebug output file: \nP",
940 doc: 941 942 943 )
944 (file, append)
945 Lisp_Object file, append;
946 {
947 if (initial_stderr_stream != NULL)
948 {
949 BLOCK_INPUT;
950 fclose (stderr);
951 UNBLOCK_INPUT;
952 }
953 stderr = initial_stderr_stream;
954 initial_stderr_stream = NULL;
955
956 if (STRINGP (file))
957 {
958 file = Fexpand_file_name (file, Qnil);
959 initial_stderr_stream = stderr;
960 stderr = fopen (SDATA (file), NILP (append) ? "w" : "a");
961 if (stderr == NULL)
962 {
963 stderr = initial_stderr_stream;
964 initial_stderr_stream = NULL;
965 report_file_error ("Cannot open debugging output stream",
966 Fcons (file, Qnil));
967 }
968 }
969 return Qnil;
970 }
971 #endif
972
973
974
975
976 void
977 debug_print (arg)
978 Lisp_Object arg;
979 {
980 Fprin1 (arg, Qexternal_debugging_output);
981 fprintf (stderr, "\r\n");
982 }
983
984 void
985 safe_debug_print (arg)
986 Lisp_Object arg;
987 {
988 int valid = valid_lisp_object_p (arg);
989
990 if (valid > 0)
991 debug_print (arg);
992 else
993 fprintf (stderr, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
994 !valid ? "INVALID" : "SOME",
995 (unsigned long) XHASH (arg)
996 );
997 }
998
999
1000 DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
1001 1, 1, 0,
1002 doc: 1003 1004 )
1005 (obj)
1006 Lisp_Object obj;
1007 {
1008 struct buffer *old = current_buffer;
1009 Lisp_Object value;
1010 struct gcpro gcpro1;
1011
1012 1013 1014
1015 if (CONSP (obj) && EQ (XCAR (obj), Qerror)
1016 && CONSP (XCDR (obj))
1017 && STRINGP (XCAR (XCDR (obj)))
1018 && NILP (XCDR (XCDR (obj))))
1019 return XCAR (XCDR (obj));
1020
1021 print_error_message (obj, Vprin1_to_string_buffer, 0, Qnil);
1022
1023 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
1024 value = Fbuffer_string ();
1025
1026 GCPRO1 (value);
1027 Ferase_buffer ();
1028 set_buffer_internal (old);
1029 UNGCPRO;
1030
1031 return value;
1032 }
1033
1034 1035 1036 1037
1038
1039 void
1040 print_error_message (data, stream, context, caller)
1041 Lisp_Object data, stream;
1042 char *context;
1043 Lisp_Object caller;
1044 {
1045 Lisp_Object errname, errmsg, file_error, tail;
1046 struct gcpro gcpro1;
1047 int i;
1048
1049 if (context != 0)
1050 write_string_1 (context, -1, stream);
1051
1052 1053
1054 if (!NILP (caller) && SYMBOLP (caller))
1055 {
1056 Lisp_Object cname = SYMBOL_NAME (caller);
1057 char *name = alloca (SBYTES (cname));
1058 bcopy (SDATA (cname), name, SBYTES (cname));
1059 message_dolog (name, SBYTES (cname), 0, 0);
1060 message_dolog (": ", 2, 0, 0);
1061 }
1062
1063 errname = Fcar (data);
1064
1065 if (EQ (errname, Qerror))
1066 {
1067 data = Fcdr (data);
1068 if (!CONSP (data))
1069 data = Qnil;
1070 errmsg = Fcar (data);
1071 file_error = Qnil;
1072 }
1073 else
1074 {
1075 Lisp_Object error_conditions;
1076 errmsg = Fget (errname, Qerror_message);
1077 error_conditions = Fget (errname, Qerror_conditions);
1078 file_error = Fmemq (Qfile_error, error_conditions);
1079 }
1080
1081
1082
1083 tail = Fcdr_safe (data);
1084 GCPRO1 (tail);
1085
1086 1087
1088 if (!NILP (file_error) && CONSP (tail))
1089 errmsg = XCAR (tail), tail = XCDR (tail);
1090
1091 if (STRINGP (errmsg))
1092 Fprinc (errmsg, stream);
1093 else
1094 write_string_1 ("peculiar error", -1, stream);
1095
1096 for (i = 0; CONSP (tail); tail = XCDR (tail), i++)
1097 {
1098 Lisp_Object obj;
1099
1100 write_string_1 (i ? ", " : ": ", 2, stream);
1101 obj = XCAR (tail);
1102 if (!NILP (file_error) || EQ (errname, Qend_of_file))
1103 Fprinc (obj, stream);
1104 else
1105 Fprin1 (obj, stream);
1106 }
1107
1108 UNGCPRO;
1109 }
1110
1111
1112
1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125
1126
1127 void
1128 float_to_string (buf, data)
1129 unsigned char *buf;
1130 double data;
1131 {
1132 unsigned char *cp;
1133 int width;
1134
1135 1136
1137 if (data == data / 2 && data > 1.0)
1138 {
1139 strcpy (buf, "1.0e+INF");
1140 return;
1141 }
1142
1143 if (data == data / 2 && data < -1.0)
1144 {
1145 strcpy (buf, "-1.0e+INF");
1146 return;
1147 }
1148
1149 if (! (data * 0.0 >= 0.0))
1150 {
1151 1152
1153 int i;
1154 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
1155 u_data.d = data;
1156 u_minus_zero.d = - 0.0;
1157 for (i = 0; i < sizeof (double); i++)
1158 if (u_data.c[i] & u_minus_zero.c[i])
1159 {
1160 *buf++ = '-';
1161 break;
1162 }
1163
1164 strcpy (buf, "0.0e+NaN");
1165 return;
1166 }
1167
1168 if (NILP (Vfloat_output_format)
1169 || !STRINGP (Vfloat_output_format))
1170 lose:
1171 {
1172 1173 1174 1175 1176 1177 1178 1179 1180 1181
1182
1183 width = fabs (data) < DBL_MIN ? 1 : DBL_DIG;
1184 do
1185 sprintf (buf, "%.*g", width, data);
1186 while (width++ < DOUBLE_DIGITS_BOUND && atof (buf) != data);
1187 }
1188 else
1189 {
1190 1191 1192
1193 cp = SDATA (Vfloat_output_format);
1194
1195 if (cp[0] != '%')
1196 goto lose;
1197 if (cp[1] != '.')
1198 goto lose;
1199
1200 cp += 2;
1201
1202
1203 width = -1;
1204 if ('0' <= *cp && *cp <= '9')
1205 {
1206 width = 0;
1207 do
1208 width = (width * 10) + (*cp++ - '0');
1209 while (*cp >= '0' && *cp <= '9');
1210
1211
1212 if (width > DBL_DIG
1213 || (width == 0 && *cp != 'f'))
1214 goto lose;
1215 }
1216
1217 if (*cp != 'e' && *cp != 'f' && *cp != 'g')
1218 goto lose;
1219
1220 if (cp[1] != 0)
1221 goto lose;
1222
1223 sprintf (buf, SDATA (Vfloat_output_format), data);
1224 }
1225
1226 1227 1228 1229
1230 if (width != 0)
1231 {
1232 for (cp = buf; *cp; cp++)
1233 if ((*cp < '0' || *cp > '9') && *cp != '-')
1234 break;
1235
1236 if (*cp == '.' && cp[1] == 0)
1237 {
1238 cp[1] = '0';
1239 cp[2] = 0;
1240 }
1241
1242 if (*cp == 0)
1243 {
1244 *cp++ = '.';
1245 *cp++ = '0';
1246 *cp++ = 0;
1247 }
1248 }
1249 }
1250
1251
1252 static void
1253 print (obj, printcharfun, escapeflag)
1254 Lisp_Object obj;
1255 register Lisp_Object printcharfun;
1256 int escapeflag;
1257 {
1258 new_backquote_output = 0;
1259
1260 1261 1262 1263
1264 if (NILP (Vprint_continuous_numbering)
1265 || NILP (Vprint_number_table))
1266 {
1267 print_number_index = 0;
1268 Vprint_number_table = Qnil;
1269 }
1270
1271
1272 if (!NILP (Vprint_gensym) || !NILP (Vprint_circle))
1273 {
1274 int i, start, index;
1275 start = index = print_number_index;
1276 1277
1278 print_depth = 0;
1279 print_preprocess (obj);
1280
1281 1282
1283 for (i = start; i < print_number_index; i++)
1284 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1285 {
1286 PRINT_NUMBER_OBJECT (Vprint_number_table, index)
1287 = PRINT_NUMBER_OBJECT (Vprint_number_table, i);
1288 index++;
1289 }
1290
1291
1292 for (i = index; i < print_number_index; i++)
1293 PRINT_NUMBER_OBJECT (Vprint_number_table, i) = Qnil;
1294
1295 1296
1297 for (i = start; i < print_number_index; i++)
1298 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qnil;
1299
1300 print_number_index = index;
1301 }
1302
1303 print_depth = 0;
1304 print_object (obj, printcharfun, escapeflag);
1305 }
1306
1307 1308 1309 1310 1311 1312 1313
1314 static void
1315 print_preprocess (obj)
1316 Lisp_Object obj;
1317 {
1318 int i;
1319 EMACS_INT size;
1320 int loop_count = 0;
1321 Lisp_Object halftail;
1322
1323
1324
1325 if (print_depth >= PRINT_CIRCLE)
1326 error ("Apparently circular structure being printed");
1327
1328 1329
1330 if (NILP (Vprint_circle))
1331 {
1332 for (i = 0; i < print_depth; i++)
1333 if (EQ (obj, being_printed[i]))
1334 return;
1335 being_printed[print_depth] = obj;
1336 }
1337
1338 print_depth++;
1339 halftail = obj;
1340
1341 loop:
1342 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1343 || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
1344 || HASH_TABLE_P (obj)
1345 || (! NILP (Vprint_gensym)
1346 && SYMBOLP (obj)
1347 && !SYMBOL_INTERNED_P (obj)))
1348 {
1349 1350
1351 if (! NILP (Vprint_circle) || SYMBOLP (obj))
1352 {
1353 for (i = 0; i < print_number_index; i++)
1354 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1355 {
1356
1357 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1358 print_depth--;
1359 return;
1360 }
1361
1362
1363 if (print_number_index == 0)
1364 {
1365
1366 Vprint_number_table = Fmake_vector (make_number (40), Qnil);
1367 }
1368 else if (XVECTOR (Vprint_number_table)->size == print_number_index * 2)
1369 {
1370
1371 int i = print_number_index * 4;
1372 Lisp_Object old_table = Vprint_number_table;
1373 Vprint_number_table = Fmake_vector (make_number (i), Qnil);
1374 for (i = 0; i < print_number_index; i++)
1375 {
1376 PRINT_NUMBER_OBJECT (Vprint_number_table, i)
1377 = PRINT_NUMBER_OBJECT (old_table, i);
1378 PRINT_NUMBER_STATUS (Vprint_number_table, i)
1379 = PRINT_NUMBER_STATUS (old_table, i);
1380 }
1381 }
1382 PRINT_NUMBER_OBJECT (Vprint_number_table, print_number_index) = obj;
1383 1384 1385
1386 if (!NILP (Vprint_continuous_numbering)
1387 && SYMBOLP (obj)
1388 && !SYMBOL_INTERNED_P (obj))
1389 PRINT_NUMBER_STATUS (Vprint_number_table, print_number_index) = Qt;
1390 print_number_index++;
1391 }
1392
1393 switch (XTYPE (obj))
1394 {
1395 case Lisp_String:
1396
1397 traverse_intervals_noorder (STRING_INTERVALS (obj),
1398 print_preprocess_string, Qnil);
1399 break;
1400
1401 case Lisp_Cons:
1402 1403
1404 if (loop_count && EQ (obj, halftail))
1405 break;
1406 print_preprocess (XCAR (obj));
1407 obj = XCDR (obj);
1408 loop_count++;
1409 if (!(loop_count & 1))
1410 halftail = XCDR (halftail);
1411 goto loop;
1412
1413 case Lisp_Vectorlike:
1414 size = XVECTOR (obj)->size;
1415 if (size & PSEUDOVECTOR_FLAG)
1416 size &= PSEUDOVECTOR_SIZE_MASK;
1417 for (i = 0; i < size; i++)
1418 print_preprocess (XVECTOR (obj)->contents[i]);
1419 if (HASH_TABLE_P (obj))
1420 { 1421 1422
1423 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
1424 print_preprocess (h->key_and_value);
1425 }
1426 break;
1427
1428 default:
1429 break;
1430 }
1431 }
1432 print_depth--;
1433 }
1434
1435 static void
1436 print_preprocess_string (interval, arg)
1437 INTERVAL interval;
1438 Lisp_Object arg;
1439 {
1440 print_preprocess (interval->plist);
1441 }
1442
1443 1444
1445 Lisp_Object Vprint_charset_text_property;
1446 extern Lisp_Object Qdefault;
1447
1448 static void print_check_string_charset_prop ();
1449
1450 #define PRINT_STRING_NON_CHARSET_FOUND 1
1451 #define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
1452
1453
1454 static int print_check_string_result;
1455
1456 static void
1457 print_check_string_charset_prop (interval, string)
1458 INTERVAL interval;
1459 Lisp_Object string;
1460 {
1461 Lisp_Object val;
1462
1463 if (NILP (interval->plist)
1464 || (print_check_string_result == (PRINT_STRING_NON_CHARSET_FOUND
1465 | PRINT_STRING_UNSAFE_CHARSET_FOUND)))
1466 return;
1467 for (val = interval->plist; CONSP (val) && ! EQ (XCAR (val), Qcharset);
1468 val = XCDR (XCDR (val)));
1469 if (! CONSP (val))
1470 {
1471 print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
1472 return;
1473 }
1474 if (! (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND))
1475 {
1476 if (! EQ (val, interval->plist)
1477 || CONSP (XCDR (XCDR (val))))
1478 print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND;
1479 }
1480 if (NILP (Vprint_charset_text_property)
1481 || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
1482 {
1483 int i, c;
1484 int charpos = interval->position;
1485 int bytepos = string_char_to_byte (string, charpos);
1486 Lisp_Object charset;
1487
1488 charset = XCAR (XCDR (val));
1489 for (i = 0; i < LENGTH (interval); i++)
1490 {
1491 FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos);
1492 if (! ASCII_CHAR_P (c)
1493 && ! EQ (CHARSET_NAME (CHAR_CHARSET (c)), charset))
1494 {
1495 print_check_string_result |= PRINT_STRING_UNSAFE_CHARSET_FOUND;
1496 break;
1497 }
1498 }
1499 }
1500 }
1501
1502
1503 static Lisp_Object print_prune_charset_plist;
1504
1505 static Lisp_Object
1506 print_prune_string_charset (string)
1507 Lisp_Object string;
1508 {
1509 print_check_string_result = 0;
1510 traverse_intervals (STRING_INTERVALS (string), 0,
1511 print_check_string_charset_prop, string);
1512 if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
1513 {
1514 string = Fcopy_sequence (string);
1515 if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND)
1516 {
1517 if (NILP (print_prune_charset_plist))
1518 print_prune_charset_plist = Fcons (Qcharset, Qnil);
1519 Fremove_text_properties (make_number (0),
1520 make_number (SCHARS (string)),
1521 print_prune_charset_plist, string);
1522 }
1523 else
1524 Fset_text_properties (make_number (0), make_number (SCHARS (string)),
1525 Qnil, string);
1526 }
1527 return string;
1528 }
1529
1530 static void
1531 print_object (obj, printcharfun, escapeflag)
1532 Lisp_Object obj;
1533 register Lisp_Object printcharfun;
1534 int escapeflag;
1535 {
1536 char buf[40];
1537
1538 QUIT;
1539
1540
1541 if (print_depth >= PRINT_CIRCLE)
1542 error ("Apparently circular structure being printed");
1543
1544
1545 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1546 || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
1547 || HASH_TABLE_P (obj)
1548 || (! NILP (Vprint_gensym)
1549 && SYMBOLP (obj)
1550 && !SYMBOL_INTERNED_P (obj)))
1551 {
1552 if (NILP (Vprint_circle) && NILP (Vprint_gensym))
1553 {
1554
1555 int i;
1556 for (i = 0; i < print_depth; i++)
1557 if (EQ (obj, being_printed[i]))
1558 {
1559 sprintf (buf, "#%d", i);
1560 strout (buf, -1, -1, printcharfun, 0);
1561 return;
1562 }
1563 being_printed[print_depth] = obj;
1564 }
1565 else
1566 {
1567
1568 int i;
1569 for (i = 0; i < print_number_index; i++)
1570 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj))
1571 {
1572 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1573 {
1574 1575
1576 sprintf (buf, "#%d=", i + 1);
1577 strout (buf, -1, -1, printcharfun, 0);
1578
1579 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt;
1580 break;
1581 }
1582 else
1583 {
1584
1585 sprintf (buf, "#%d#", i + 1);
1586 strout (buf, -1, -1, printcharfun, 0);
1587 return;
1588 }
1589 }
1590 }
1591 }
1592
1593 print_depth++;
1594
1595 switch (XTYPE (obj))
1596 {
1597 case_Lisp_Int:
1598 if (sizeof (int) == sizeof (EMACS_INT))
1599 sprintf (buf, "%d", (int) XINT (obj));
1600 else if (sizeof (long) == sizeof (EMACS_INT))
1601 sprintf (buf, "%ld", (long) XINT (obj));
1602 else
1603 abort ();
1604 strout (buf, -1, -1, printcharfun, 0);
1605 break;
1606
1607 case Lisp_Float:
1608 {
1609 char pigbuf[350];
1610
1611 float_to_string (pigbuf, XFLOAT_DATA (obj));
1612 strout (pigbuf, -1, -1, printcharfun, 0);
1613 }
1614 break;
1615
1616 case Lisp_String:
1617 if (!escapeflag)
1618 print_string (obj, printcharfun);
1619 else
1620 {
1621 register int i, i_byte;
1622 struct gcpro gcpro1;
1623 unsigned char *str;
1624 int size_byte;
1625 1626
1627 int need_nonhex = 0;
1628 int multibyte = STRING_MULTIBYTE (obj);
1629
1630 GCPRO1 (obj);
1631
1632 if (! EQ (Vprint_charset_text_property, Qt))
1633 obj = print_prune_string_charset (obj);
1634
1635 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj)))
1636 {
1637 PRINTCHAR ('#');
1638 PRINTCHAR ('(');
1639 }
1640
1641 PRINTCHAR ('\"');
1642 str = SDATA (obj);
1643 size_byte = SBYTES (obj);
1644
1645 for (i = 0, i_byte = 0; i_byte < size_byte;)
1646 {
1647 1648
1649 int len;
1650 int c;
1651
1652 if (multibyte)
1653 {
1654 c = STRING_CHAR_AND_LENGTH (str + i_byte, len);
1655 i_byte += len;
1656 }
1657 else
1658 c = str[i_byte++];
1659
1660 QUIT;
1661
1662 if (c == '\n' && print_escape_newlines)
1663 {
1664 PRINTCHAR ('\\');
1665 PRINTCHAR ('n');
1666 }
1667 else if (c == '\f' && print_escape_newlines)
1668 {
1669 PRINTCHAR ('\\');
1670 PRINTCHAR ('f');
1671 }
1672 else if (multibyte
1673 && (CHAR_BYTE8_P (c)
1674 || (! ASCII_CHAR_P (c) && print_escape_multibyte)))
1675 {
1676 1677 1678 1679 1680
1681 unsigned char outbuf[50];
1682
1683 if (CHAR_BYTE8_P (c))
1684 sprintf (outbuf, "\\%03o", CHAR_TO_BYTE8 (c));
1685 else
1686 {
1687 sprintf (outbuf, "\\x%04x", c);
1688 need_nonhex = 1;
1689 }
1690 strout (outbuf, -1, -1, printcharfun, 0);
1691 }
1692 else if (! multibyte
1693 && SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c)
1694 && print_escape_nonascii)
1695 {
1696 1697 1698 1699
1700 unsigned char outbuf[5];
1701 sprintf (outbuf, "\\%03o", c);
1702 strout (outbuf, -1, -1, printcharfun, 0);
1703 }
1704 else
1705 {
1706 1707 1708
1709 if (need_nonhex)
1710 {
1711 need_nonhex = 0;
1712 if ((c >= 'a' && c <= 'f')
1713 || (c >= 'A' && c <= 'F')
1714 || (c >= '0' && c <= '9'))
1715 strout ("\\ ", -1, -1, printcharfun, 0);
1716 }
1717
1718 if (c == '\"' || c == '\\')
1719 PRINTCHAR ('\\');
1720 PRINTCHAR (c);
1721 }
1722 }
1723 PRINTCHAR ('\"');
1724
1725 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj)))
1726 {
1727 traverse_intervals (STRING_INTERVALS (obj),
1728 0, print_interval, printcharfun);
1729 PRINTCHAR (')');
1730 }
1731
1732 UNGCPRO;
1733 }
1734 break;
1735
1736 case Lisp_Symbol:
1737 {
1738 register int confusing;
1739 register unsigned char *p = SDATA (SYMBOL_NAME (obj));
1740 register unsigned char *end = p + SBYTES (SYMBOL_NAME (obj));
1741 register int c;
1742 int i, i_byte, size_byte;
1743 Lisp_Object name;
1744
1745 name = SYMBOL_NAME (obj);
1746
1747 if (p != end && (*p == '-' || *p == '+')) p++;
1748 if (p == end)
1749 confusing = 0;
1750 1751 1752 1753 1754 1755 1756
1757 else if (*p >= '0' && *p <= '9'
1758 && end[-1] >= '0' && end[-1] <= '9')
1759 {
1760 while (p != end && ((*p >= '0' && *p <= '9')
1761
1762 || *p == 'e' || *p == 'E'))
1763 p++;
1764 confusing = (end == p);
1765 }
1766 else
1767 confusing = 0;
1768
1769 if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj))
1770 {
1771 PRINTCHAR ('#');
1772 PRINTCHAR (':');
1773 }
1774
1775 size_byte = SBYTES (name);
1776
1777 for (i = 0, i_byte = 0; i_byte < size_byte;)
1778 {
1779 1780
1781 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte);
1782 QUIT;
1783
1784 if (escapeflag)
1785 {
1786 if (c == '\"' || c == '\\' || c == '\''
1787 || c == ';' || c == '#' || c == '(' || c == ')'
1788 || c == ',' || c =='.' || c == '`'
1789 || c == '[' || c == ']' || c == '?' || c <= 040
1790 || confusing)
1791 PRINTCHAR ('\\'), confusing = 0;
1792 }
1793 PRINTCHAR (c);
1794 }
1795 }
1796 break;
1797
1798 case Lisp_Cons:
1799
1800 if (INTEGERP (Vprint_level)
1801 && print_depth > XINT (Vprint_level))
1802 strout ("...", -1, -1, printcharfun, 0);
1803 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1804 && (EQ (XCAR (obj), Qquote)))
1805 {
1806 PRINTCHAR ('\'');
1807 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1808 }
1809 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1810 && (EQ (XCAR (obj), Qfunction)))
1811 {
1812 PRINTCHAR ('#');
1813 PRINTCHAR ('\'');
1814 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1815 }
1816 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1817 && ((EQ (XCAR (obj), Qbackquote))))
1818 {
1819 print_object (XCAR (obj), printcharfun, 0);
1820 new_backquote_output++;
1821 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1822 new_backquote_output--;
1823 }
1824 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
1825 && new_backquote_output
1826 && ((EQ (XCAR (obj), Qbackquote)
1827 || EQ (XCAR (obj), Qcomma)
1828 || EQ (XCAR (obj), Qcomma_at)
1829 || EQ (XCAR (obj), Qcomma_dot))))
1830 {
1831 print_object (XCAR (obj), printcharfun, 0);
1832 new_backquote_output--;
1833 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
1834 new_backquote_output++;
1835 }
1836 else
1837 {
1838 PRINTCHAR ('(');
1839
1840 1841
1842 if (print_quoted && CONSP (XCAR (obj))
1843 && CONSP (XCDR (XCAR (obj)))
1844 && NILP (XCDR (XCDR (XCAR (obj))))
1845 && EQ (XCAR (XCAR (obj)), Qbackquote))
1846 {
1847 Lisp_Object tem;
1848 tem = XCAR (obj);
1849 PRINTCHAR ('(');
1850
1851 print_object (Qbackquote, printcharfun, 0);
1852 PRINTCHAR (' ');
1853
1854 print_object (XCAR (XCDR (tem)), printcharfun, 0);
1855 PRINTCHAR (')');
1856
1857 obj = XCDR (obj);
1858 }
1859
1860 {
1861 int print_length, i;
1862 Lisp_Object halftail = obj;
1863
1864 1865
1866 if (NATNUMP (Vprint_length))
1867 print_length = XFASTINT (Vprint_length);
1868 else
1869 print_length = 0;
1870
1871 i = 0;
1872 while (CONSP (obj))
1873 {
1874
1875 if (NILP (Vprint_circle))
1876 {
1877
1878 if (i != 0 && EQ (obj, halftail))
1879 {
1880 sprintf (buf, " . #%d", i / 2);
1881 strout (buf, -1, -1, printcharfun, 0);
1882 goto end_of_list;
1883 }
1884 }
1885 else
1886 {
1887
1888 if (i != 0)
1889 {
1890 int i;
1891 for (i = 0; i < print_number_index; i++)
1892 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i),
1893 obj))
1894 {
1895 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i)))
1896 {
1897 strout (" . ", 3, 3, printcharfun, 0);
1898 print_object (obj, printcharfun, escapeflag);
1899 }
1900 else
1901 {
1902 sprintf (buf, " . #%d#", i + 1);
1903 strout (buf, -1, -1, printcharfun, 0);
1904 }
1905 goto end_of_list;
1906 }
1907 }
1908 }
1909
1910 if (i++)
1911 PRINTCHAR (' ');
1912
1913 if (print_length && i > print_length)
1914 {
1915 strout ("...", 3, 3, printcharfun, 0);
1916 goto end_of_list;
1917 }
1918
1919 print_object (XCAR (obj), printcharfun, escapeflag);
1920
1921 obj = XCDR (obj);
1922 if (!(i & 1))
1923 halftail = XCDR (halftail);
1924 }
1925 }
1926
1927
1928 if (!NILP (obj))
1929 {
1930 strout (" . ", 3, 3, printcharfun, 0);
1931 print_object (obj, printcharfun, escapeflag);
1932 }
1933
1934 end_of_list:
1935 PRINTCHAR (')');
1936 }
1937 break;
1938
1939 case Lisp_Vectorlike:
1940 if (PROCESSP (obj))
1941 {
1942 if (escapeflag)
1943 {
1944 strout ("#<process ", -1, -1, printcharfun, 0);
1945 print_string (XPROCESS (obj)->name, printcharfun);
1946 PRINTCHAR ('>');
1947 }
1948 else
1949 print_string (XPROCESS (obj)->name, printcharfun);
1950 }
1951 else if (BOOL_VECTOR_P (obj))
1952 {
1953 register int i;
1954 register unsigned char c;
1955 struct gcpro gcpro1;
1956 int size_in_chars
1957 = ((XBOOL_VECTOR (obj)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
1958 / BOOL_VECTOR_BITS_PER_CHAR);
1959
1960 GCPRO1 (obj);
1961
1962 PRINTCHAR ('#');
1963 PRINTCHAR ('&');
1964 sprintf (buf, "%ld", (long) XBOOL_VECTOR (obj)->size);
1965 strout (buf, -1, -1, printcharfun, 0);
1966 PRINTCHAR ('\"');
1967
1968 1969 1970
1971 if (NATNUMP (Vprint_length)
1972 && XFASTINT (Vprint_length) < size_in_chars)
1973 size_in_chars = XFASTINT (Vprint_length);
1974
1975 for (i = 0; i < size_in_chars; i++)
1976 {
1977 QUIT;
1978 c = XBOOL_VECTOR (obj)->data[i];
1979 if (c == '\n' && print_escape_newlines)
1980 {
1981 PRINTCHAR ('\\');
1982 PRINTCHAR ('n');
1983 }
1984 else if (c == '\f' && print_escape_newlines)
1985 {
1986 PRINTCHAR ('\\');
1987 PRINTCHAR ('f');
1988 }
1989 else if (c > '\177')
1990 {
1991
1992 PRINTCHAR ('\\');
1993 PRINTCHAR ('0' + ((c >> 6) & 3));
1994 PRINTCHAR ('0' + ((c >> 3) & 7));
1995 PRINTCHAR ('0' + (c & 7));
1996 }
1997 else
1998 {
1999 if (c == '\"' || c == '\\')
2000 PRINTCHAR ('\\');
2001 PRINTCHAR (c);
2002 }
2003 }
2004 PRINTCHAR ('\"');
2005
2006 UNGCPRO;
2007 }
2008 else if (SUBRP (obj))
2009 {
2010 strout ("#<subr ", -1, -1, printcharfun, 0);
2011 strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun, 0);
2012 PRINTCHAR ('>');
2013 }
2014 else if (WINDOWP (obj))
2015 {
2016 strout ("#<window ", -1, -1, printcharfun, 0);
2017 sprintf (buf, "%ld", (long) XFASTINT (XWINDOW (obj)->sequence_number));
2018 strout (buf, -1, -1, printcharfun, 0);
2019 if (!NILP (XWINDOW (obj)->buffer))
2020 {
2021 strout (" on ", -1, -1, printcharfun, 0);
2022 print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun);
2023 }
2024 PRINTCHAR ('>');
2025 }
2026 else if (TERMINALP (obj))
2027 {
2028 struct terminal *t = XTERMINAL (obj);
2029 strout ("#<terminal ", -1, -1, printcharfun, 0);
2030 sprintf (buf, "%d", t->id);
2031 strout (buf, -1, -1, printcharfun, 0);
2032 if (t->name)
2033 {
2034 strout (" on ", -1, -1, printcharfun, 0);
2035 strout (t->name, -1, -1, printcharfun, 0);
2036 }
2037 PRINTCHAR ('>');
2038 }
2039 else if (HASH_TABLE_P (obj))
2040 {
2041 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
2042 int i, real_size, size;
2043 #if 0
2044 strout ("#<hash-table", -1, -1, printcharfun, 0);
2045 if (SYMBOLP (h->test))
2046 {
2047 PRINTCHAR (' ');
2048 PRINTCHAR ('\'');
2049 strout (SDATA (SYMBOL_NAME (h->test)), -1, -1, printcharfun, 0);
2050 PRINTCHAR (' ');
2051 strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun, 0);
2052 PRINTCHAR (' ');
2053 sprintf (buf, "%ld/%ld", (long) h->count,
2054 (long) XVECTOR (h->next)->size);
2055 strout (buf, -1, -1, printcharfun, 0);
2056 }
2057 sprintf (buf, " 0x%lx", (unsigned long) h);
2058 strout (buf, -1, -1, printcharfun, 0);
2059 PRINTCHAR ('>');
2060 #endif
2061 2062
2063
2064 sprintf (buf, "#s(hash-table size %ld",
2065 (long) XVECTOR (h->next)->size);
2066 strout (buf, -1, -1, printcharfun, 0);
2067
2068 if (!NILP (h->test))
2069 {
2070 strout (" test ", -1, -1, printcharfun, 0);
2071 print_object (h->test, printcharfun, 0);
2072 }
2073
2074 if (!NILP (h->weak))
2075 {
2076 strout (" weakness ", -1, -1, printcharfun, 0);
2077 print_object (h->weak, printcharfun, 0);
2078 }
2079
2080 if (!NILP (h->rehash_size))
2081 {
2082 strout (" rehash-size ", -1, -1, printcharfun, 0);
2083 print_object (h->rehash_size, printcharfun, 0);
2084 }
2085
2086 if (!NILP (h->rehash_threshold))
2087 {
2088 strout (" rehash-threshold ", -1, -1, printcharfun, 0);
2089 print_object (h->rehash_threshold, printcharfun, 0);
2090 }
2091
2092 strout (" data ", -1, -1, printcharfun, 0);
2093
2094
2095 real_size = HASH_TABLE_SIZE (h);
2096 size = real_size;
2097
2098
2099 if (NATNUMP (Vprint_length)
2100 && XFASTINT (Vprint_length) < size)
2101 size = XFASTINT (Vprint_length);
2102
2103 PRINTCHAR ('(');
2104 for (i = 0; i < size; i++)
2105 if (!NILP (HASH_HASH (h, i)))
2106 {
2107 if (i) PRINTCHAR (' ');
2108 print_object (HASH_KEY (h, i), printcharfun, 1);
2109 PRINTCHAR (' ');
2110 print_object (HASH_VALUE (h, i), printcharfun, 1);
2111 }
2112
2113 if (size < real_size)
2114 strout (" ...", 4, 4, printcharfun, 0);
2115
2116 PRINTCHAR (')');
2117 PRINTCHAR (')');
2118
2119 }
2120 else if (BUFFERP (obj))
2121 {
2122 if (NILP (XBUFFER (obj)->name))
2123 strout ("#<killed buffer>", -1, -1, printcharfun, 0);
2124 else if (escapeflag)
2125 {
2126 strout ("#<buffer ", -1, -1, printcharfun, 0);
2127 print_string (XBUFFER (obj)->name, printcharfun);
2128 PRINTCHAR ('>');
2129 }
2130 else
2131 print_string (XBUFFER (obj)->name, printcharfun);
2132 }
2133 else if (WINDOW_CONFIGURATIONP (obj))
2134 {
2135 strout ("#<window-configuration>", -1, -1, printcharfun, 0);
2136 }
2137 else if (FRAMEP (obj))
2138 {
2139 strout ((FRAME_LIVE_P (XFRAME (obj))
2140 ? "#<frame " : "#<dead frame "),
2141 -1, -1, printcharfun, 0);
2142 print_string (XFRAME (obj)->name, printcharfun);
2143 sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj)));
2144 strout (buf, -1, -1, printcharfun, 0);
2145 PRINTCHAR ('>');
2146 }
2147 else if (FONTP (obj))
2148 {
2149 EMACS_INT i;
2150
2151 if (! FONT_OBJECT_P (obj))
2152 {
2153 if (FONT_SPEC_P (obj))
2154 strout ("#<font-spec", -1, -1, printcharfun, 0);
2155 else
2156 strout ("#<font-entity", -1, -1, printcharfun, 0);
2157 for (i = 0; i < FONT_SPEC_MAX; i++)
2158 {
2159 PRINTCHAR (' ');
2160 if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
2161 print_object (AREF (obj, i), printcharfun, escapeflag);
2162 else
2163 print_object (font_style_symbolic (obj, i, 0),
2164 printcharfun, escapeflag);
2165 }
2166 }
2167 else
2168 {
2169 strout ("#<font-object ", -1, -1, printcharfun, 0);
2170 print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
2171 escapeflag);
2172 }
2173 PRINTCHAR ('>');
2174 }
2175 else
2176 {
2177 EMACS_INT size = XVECTOR (obj)->size;
2178 if (COMPILEDP (obj))
2179 {
2180 PRINTCHAR ('#');
2181 size &= PSEUDOVECTOR_SIZE_MASK;
2182 }
2183 if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
2184 {
2185 2186 2187
2188
2189 2190 2191
2192 if (SUB_CHAR_TABLE_P (obj)
2193 && XINT (XSUB_CHAR_TABLE (obj)->depth) == 3)
2194 PRINTCHAR ('\n');
2195 PRINTCHAR ('#');
2196 PRINTCHAR ('^');
2197 if (SUB_CHAR_TABLE_P (obj))
2198 PRINTCHAR ('^');
2199 size &= PSEUDOVECTOR_SIZE_MASK;
2200 }
2201 if (size & PSEUDOVECTOR_FLAG)
2202 goto badtype;
2203
2204 PRINTCHAR ('[');
2205 {
2206 register int i;
2207 register Lisp_Object tem;
2208 int real_size = size;
2209
2210
2211 if (NATNUMP (Vprint_length)
2212 && XFASTINT (Vprint_length) < size)
2213 size = XFASTINT (Vprint_length);
2214
2215 for (i = 0; i < size; i++)
2216 {
2217 if (i) PRINTCHAR (' ');
2218 tem = XVECTOR (obj)->contents[i];
2219 print_object (tem, printcharfun, escapeflag);
2220 }
2221 if (size < real_size)
2222 strout (" ...", 4, 4, printcharfun, 0);
2223 }
2224 PRINTCHAR (']');
2225 }
2226 break;
2227
2228 case Lisp_Misc:
2229 switch (XMISCTYPE (obj))
2230 {
2231 case Lisp_Misc_Marker:
2232 strout ("#<marker ", -1, -1, printcharfun, 0);
2233
2234 if (XMARKER (obj)->insertion_type != 0)
2235 strout ("(moves after insertion) ", -1, -1, printcharfun, 0);
2236 if (! XMARKER (obj)->buffer)
2237 strout ("in no buffer", -1, -1, printcharfun, 0);
2238 else
2239 {
2240 sprintf (buf, "at %d", marker_position (obj));
2241 strout (buf, -1, -1, printcharfun, 0);
2242 strout (" in ", -1, -1, printcharfun, 0);
2243 print_string (XMARKER (obj)->buffer->name, printcharfun);
2244 }
2245 PRINTCHAR ('>');
2246 break;
2247
2248 case Lisp_Misc_Overlay:
2249 strout ("#<overlay ", -1, -1, printcharfun, 0);
2250 if (! XMARKER (OVERLAY_START (obj))->buffer)
2251 strout ("in no buffer", -1, -1, printcharfun, 0);
2252 else
2253 {
2254 sprintf (buf, "from %d to %d in ",
2255 marker_position (OVERLAY_START (obj)),
2256 marker_position (OVERLAY_END (obj)));
2257 strout (buf, -1, -1, printcharfun, 0);
2258 print_string (XMARKER (OVERLAY_START (obj))->buffer->name,
2259 printcharfun);
2260 }
2261 PRINTCHAR ('>');
2262 break;
2263
2264 2265
2266 case Lisp_Misc_Free:
2267 strout ("#<misc free cell>", -1, -1, printcharfun, 0);
2268 break;
2269
2270 case Lisp_Misc_Save_Value:
2271 strout ("#<save_value ", -1, -1, printcharfun, 0);
2272 sprintf(buf, "ptr=0x%08lx int=%d",
2273 (unsigned long) XSAVE_VALUE (obj)->pointer,
2274 XSAVE_VALUE (obj)->integer);
2275 strout (buf, -1, -1, printcharfun, 0);
2276 PRINTCHAR ('>');
2277 break;
2278
2279 default:
2280 goto badtype;
2281 }
2282 break;
2283
2284 default:
2285 badtype:
2286 {
2287 2288
2289 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun, 0);
2290 if (MISCP (obj))
2291 sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
2292 else if (VECTORLIKEP (obj))
2293 sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
2294 else
2295 sprintf (buf, "(0x%02x)", (int) XTYPE (obj));
2296 strout (buf, -1, -1, printcharfun, 0);
2297 strout (" Save your buffers immediately and please report this bug>",
2298 -1, -1, printcharfun, 0);
2299 }
2300 }
2301
2302 print_depth--;
2303 }
2304
2305
2306 2307
2308
2309 void
2310 print_interval (interval, printcharfun)
2311 INTERVAL interval;
2312 Lisp_Object printcharfun;
2313 {
2314 if (NILP (interval->plist))
2315 return;
2316 PRINTCHAR (' ');
2317 print_object (make_number (interval->position), printcharfun, 1);
2318 PRINTCHAR (' ');
2319 print_object (make_number (interval->position + LENGTH (interval)),
2320 printcharfun, 1);
2321 PRINTCHAR (' ');
2322 print_object (interval->plist, printcharfun, 1);
2323 }
2324
2325
2326 void
2327 syms_of_print ()
2328 {
2329 Qtemp_buffer_setup_hook = intern_c_string ("temp-buffer-setup-hook");
2330 staticpro (&Qtemp_buffer_setup_hook);
2331
2332 DEFVAR_LISP ("standard-output", &Vstandard_output,
2333 doc: 2334 2335 2336 2337 );
2338 Vstandard_output = Qt;
2339 Qstandard_output = intern_c_string ("standard-output");
2340 staticpro (&Qstandard_output);
2341
2342 DEFVAR_LISP ("float-output-format", &Vfloat_output_format,
2343 doc: 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 );
2358 Vfloat_output_format = Qnil;
2359 Qfloat_output_format = intern_c_string ("float-output-format");
2360 staticpro (&Qfloat_output_format);
2361
2362 DEFVAR_LISP ("print-length", &Vprint_length,
2363 doc: 2364 );
2365 Vprint_length = Qnil;
2366
2367 DEFVAR_LISP ("print-level", &Vprint_level,
2368 doc: 2369 );
2370 Vprint_level = Qnil;
2371
2372 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
2373 doc: 2374 );
2375 print_escape_newlines = 0;
2376
2377 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii,
2378 doc: 2379 2380 2381 2382 );
2383 print_escape_nonascii = 0;
2384
2385 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte,
2386 doc: 2387 2388 );
2389 print_escape_multibyte = 0;
2390
2391 DEFVAR_BOOL ("print-quoted", &print_quoted,
2392 doc: 2393 );
2394 print_quoted = 0;
2395
2396 DEFVAR_LISP ("print-gensym", &Vprint_gensym,
2397 doc: 2398 2399 2400 2401 2402 );
2403 Vprint_gensym = Qnil;
2404
2405 DEFVAR_LISP ("print-circle", &Vprint_circle,
2406 doc: 2407 2408 2409 2410 2411 2412 2413 2414 );
2415 Vprint_circle = Qnil;
2416
2417 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering,
2418 doc: 2419 2420 2421 );
2422 Vprint_continuous_numbering = Qnil;
2423
2424 DEFVAR_LISP ("print-number-table", &Vprint_number_table,
2425 doc: 2426 2427 2428 2429 2430 2431 2432 2433 2434 );
2435 Vprint_number_table = Qnil;
2436
2437 DEFVAR_LISP ("print-charset-text-property", &Vprint_charset_text_property,
2438 doc: 2439 2440 2441 2442 2443 2444 2445 2446 2447 );
2448 Vprint_charset_text_property = Qdefault;
2449
2450
2451 staticpro (&Vprin1_to_string_buffer);
2452
2453 defsubr (&Sprin1);
2454 defsubr (&Sprin1_to_string);
2455 defsubr (&Serror_message_string);
2456 defsubr (&Sprinc);
2457 defsubr (&Sprint);
2458 defsubr (&Sterpri);
2459 defsubr (&Swrite_char);
2460 defsubr (&Sexternal_debugging_output);
2461 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
2462 defsubr (&Sredirect_debugging_output);
2463 #endif
2464
2465 Qexternal_debugging_output = intern_c_string ("external-debugging-output");
2466 staticpro (&Qexternal_debugging_output);
2467
2468 Qprint_escape_newlines = intern_c_string ("print-escape-newlines");
2469 staticpro (&Qprint_escape_newlines);
2470
2471 Qprint_escape_multibyte = intern_c_string ("print-escape-multibyte");
2472 staticpro (&Qprint_escape_multibyte);
2473
2474 Qprint_escape_nonascii = intern_c_string ("print-escape-nonascii");
2475 staticpro (&Qprint_escape_nonascii);
2476
2477 print_prune_charset_plist = Qnil;
2478 staticpro (&print_prune_charset_plist);
2479
2480 defsubr (&Swith_output_to_temp_buffer);
2481 }
2482
2483 2484