Mercurial > hg > xemacs-beta
annotate src/print.c @ 5797:a1808d52a34a
If the position of a window's cached point is deleted, use buffer point instead
src/ChangeLog addition:
2014-06-17 Aidan Kehoe <kehoea@parhasard.net>
* extents.h:
* window.c:
* window.c (unshow_buffer):
* window.c (Fset_window_buffer):
Use extents, rather than markers, for the window buffer point
cache, so that when the text containing that window buffer point
is deleted, the window display code uses the buffer's actual point
instead of the position that the marker had been moved to.
Fixes Michael Heinrich's problem of
http://mid.gmane.org/6zr42uxtf5.fsf@elektra.science-computing.de ,
introduced by Ben's patch of
https://bitbucket.org/xemacs/xemacs/commits/047d37eb70d70f43803 .
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Tue, 17 Jun 2014 20:55:45 +0100 |
| parents | acf1c26e3019 |
| children | ee27ca517e90 |
| rev | line source |
|---|---|
| 428 | 1 /* Lisp object printing and output streams. |
| 2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc. | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2005, 2010 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5243
diff
changeset
|
7 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 8 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5243
diff
changeset
|
9 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5243
diff
changeset
|
10 option) any later version. |
| 428 | 11 |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5243
diff
changeset
|
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 19 |
| 20 /* Synched up with: Not synched with FSF. */ | |
| 21 | |
| 22 /* This file has been Mule-ized. */ | |
| 23 | |
| 771 | 24 /* Seriously divergent from FSF by this point. |
| 25 | |
| 26 Seriously hacked on by Ben Wing for Mule. All stdio code also by Ben, | |
| 27 as well as the debugging code (initial version of debug_print(), though, | |
| 28 by Jamie Zawinski) and the _fmt interfaces. Also a fair amount of work | |
| 29 by Hrvoje, e.g. floating-point code and rewriting to avoid O(N^2) | |
| 30 consing when outputting to the echo area. Print-circularity code by | |
| 31 Martin? */ | |
| 428 | 32 |
| 33 #include <config.h> | |
| 34 #include "lisp.h" | |
| 35 | |
| 36 #include "backtrace.h" | |
| 37 #include "buffer.h" | |
| 38 #include "bytecode.h" | |
| 872 | 39 #include "device-impl.h" |
| 428 | 40 #include "extents.h" |
| 41 #include "frame.h" | |
| 42 #include "insdel.h" | |
| 43 #include "lstream.h" | |
| 771 | 44 #include "opaque.h" |
| 800 | 45 |
| 872 | 46 #include "console-tty-impl.h" |
| 47 #include "console-stream-impl.h" | |
| 442 | 48 #ifdef WIN32_NATIVE |
| 49 #include "console-msw.h" | |
| 50 #endif | |
| 428 | 51 |
| 800 | 52 #include "sysfile.h" |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
53 #include "elhash.h" |
| 800 | 54 |
| 428 | 55 #include <float.h> |
| 56 /* Define if not in float.h */ | |
| 57 #ifndef DBL_DIG | |
| 58 #define DBL_DIG 16 | |
| 59 #endif | |
| 60 | |
| 61 Lisp_Object Vstandard_output, Qstandard_output; | |
| 62 | |
| 63 /* The subroutine object for external-debugging-output is kept here | |
| 64 for the convenience of the debugger. */ | |
| 442 | 65 Lisp_Object Qexternal_debugging_output, Qalternate_debugging_output; |
| 66 | |
| 67 #ifdef HAVE_MS_WINDOWS | |
| 68 Lisp_Object Qmswindows_debugging_output; | |
| 69 #endif | |
| 428 | 70 |
| 71 /* Avoid actual stack overflow in print. */ | |
| 72 static int print_depth; | |
| 73 | |
| 74 /* Detect most circularities to print finite output. */ | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
75 #define PRINT_CIRCLE_LIMIT 200 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
76 static Lisp_Object being_printed[PRINT_CIRCLE_LIMIT]; |
| 428 | 77 |
| 78 /* Maximum length of list or vector to print in full; noninteger means | |
| 79 effectively infinity */ | |
| 80 | |
| 81 Lisp_Object Vprint_length; | |
| 82 Lisp_Object Qprint_length; | |
| 83 | |
| 84 /* Maximum length of string to print in full; noninteger means | |
| 85 effectively infinity */ | |
| 86 | |
| 87 Lisp_Object Vprint_string_length; | |
| 88 Lisp_Object Qprint_string_length; | |
| 89 | |
| 90 /* Maximum depth of list to print in full; noninteger means | |
| 91 effectively infinity. */ | |
| 92 | |
| 93 Lisp_Object Vprint_level; | |
| 94 | |
| 95 /* Label to use when making echo-area messages. */ | |
| 96 | |
| 97 Lisp_Object Vprint_message_label; | |
| 98 | |
| 99 /* Nonzero means print newlines in strings as \n. */ | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
100 Boolint print_escape_newlines; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
101 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
102 Boolint print_readably; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
103 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
104 /* Non-zero means print #: before uninterned symbols, and use the #n= and |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
105 #n# syntax for them. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
106 Boolint print_gensym; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
107 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
108 /* Non-zero means print recursive structures using #n= and #n# syntax. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
109 Boolint print_circle; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
110 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
111 /* Non-zero means keep continuous numbers for #n= and #n# syntax between |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
112 several print functions. Setting or binding the corresponding Lisp |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
113 variable to a non-nil value silently *clears* Vprint_number_table. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
114 Boolint print_continuous_numbering; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
115 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
116 /* Vprint_number_table is a hash table mapping objects to their statuses for |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
117 this print operation. The statuses are represented by integers. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
118 Lisp_Object Vprint_number_table; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
119 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
120 /* These describe the bit fields of the integers in Vprint_number_table. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
121 enum PRINT_NUMBER_FIELDS { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
122 /* Lowest four bits describe the number of times a given object has |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
123 been seen, allowing entries to be manipulated cheaply by |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
124 inchash_eq() when encountered. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
125 PRINT_NUMBER_SEEN_MASK = 0xF, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
126 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
127 /* The next twenty-five bits give the sequence number for the object, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
128 corresponding to the order in which print_preprocess encountered the |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
129 objects; as such, it's related to print_number_index. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
130 PRINT_NUMBER_ORDINAL_MASK = 0x1FFFFFF0, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
131 PRINT_NUMBER_ORDINAL_SHIFT = 4, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
132 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
133 /* And the next bit describes whether the object has already been printed |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
134 in this print operation (or in these print operations, if |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
135 print-continuous-numbering is relevant). */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
136 PRINT_NUMBER_PRINTED_MASK = 0x20000000, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
137 }; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
138 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
139 /* Reflects the number of repeated or possibly-repeated objects encountered |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
140 by print_preprocess(); reset whenever Vprint_number_table is cleared. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
141 Elemcount print_number_index; |
| 428 | 142 |
| 143 Lisp_Object Qdisplay_error; | |
| 144 Lisp_Object Qprint_message_label; | |
| 145 | |
|
5772
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
146 Lisp_Object Qwrite_sequence; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
147 |
| 428 | 148 /* Force immediate output of all printed data. Used for debugging. */ |
| 149 int print_unbuffered; | |
| 150 | |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
151 /* Non-zero if in debug-printing */ |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
152 int in_debug_print; |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
153 |
| 428 | 154 FILE *termscript; /* Stdio stream being used for copy of all output. */ |
| 155 | |
| 1346 | 156 static void write_string_to_alternate_debugging_output (const Ibyte *str, |
| 771 | 157 Bytecount len); |
| 158 | |
| 1957 | 159 /* To avoid consing in debug_prin1, we package up variables we need to bind |
| 160 into an opaque object. */ | |
| 161 struct debug_bindings | |
| 162 { | |
| 2367 | 163 int inhibit_non_essential_conversion_operations; |
| 1957 | 164 int print_depth; |
| 165 int print_readably; | |
| 166 int print_unbuffered; | |
|
5796
acf1c26e3019
Bind print-circle when printing backtraces.
Jerry James <james@xemacs.org>
parents:
5776
diff
changeset
|
167 int print_circle; |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
168 int in_debug_print; |
| 1957 | 169 int gc_currently_forbidden; |
| 170 Lisp_Object Vprint_length; | |
| 171 Lisp_Object Vprint_level; | |
| 172 Lisp_Object Vinhibit_quit; | |
| 173 }; | |
| 174 | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
175 static int begin_inhibit_non_essential_conversion_operations (void); |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
176 |
| 428 | 177 |
| 178 | |
| 179 int stdout_needs_newline; | |
| 1346 | 180 int stdout_clear_before_next_output; |
| 428 | 181 |
| 771 | 182 /* Basic function to actually write to a stdio stream or TTY console. */ |
| 183 | |
| 442 | 184 static void |
| 1346 | 185 write_string_to_stdio_stream_1 (FILE *stream, struct console *con, |
| 186 const Ibyte *ptr, Bytecount len, | |
| 187 int must_flush) | |
| 428 | 188 { |
| 771 | 189 Extbyte *extptr = 0; |
| 190 Bytecount extlen = 0; | |
| 191 int output_is_std_handle = | |
| 192 stream ? stream == stdout || stream == stderr : | |
| 193 CONSOLE_TTY_DATA (con)->is_stdio; | |
| 194 | |
| 195 if (stream || output_is_std_handle) | |
| 196 { | |
| 2367 | 197 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 198 TO_EXTERNAL_FORMAT (DATA, (ptr, len), |
| 199 ALLOCA, (extptr, extlen), | |
| 200 Qterminal); | |
| 201 else | |
| 202 { | |
| 2367 | 203 #ifdef NON_ASCII_INTERNAL_FORMAT |
| 204 #error Do something here | |
| 205 #else | |
| 771 | 206 extptr = (Extbyte *) ptr; |
| 207 extlen = (Bytecount) len; | |
| 2367 | 208 #endif |
| 771 | 209 } |
| 210 } | |
| 211 | |
| 428 | 212 if (stream) |
| 213 { | |
| 442 | 214 #ifdef WIN32_NATIVE |
| 215 HANDLE errhand = GetStdHandle (STD_INPUT_HANDLE); | |
| 216 int no_useful_stderr = errhand == 0 || errhand == INVALID_HANDLE_VALUE; | |
| 217 | |
| 218 if (!no_useful_stderr) | |
| 219 no_useful_stderr = !PeekNamedPipe (errhand, 0, 0, 0, 0, 0); | |
| 220 /* we typically have no useful stdout/stderr under windows if we're | |
| 221 being invoked graphically. */ | |
| 222 if (no_useful_stderr) | |
| 771 | 223 mswindows_output_console_string (ptr, len); |
| 442 | 224 else |
| 428 | 225 #endif |
| 442 | 226 { |
| 771 | 227 retry_fwrite (extptr, 1, extlen, stream); |
| 442 | 228 #ifdef WIN32_NATIVE |
| 229 /* Q122442 says that pipes are "treated as files, not as | |
| 230 devices", and that this is a feature. Before I found that | |
| 231 article, I thought it was a bug. Thanks MS, I feel much | |
| 232 better now. - kkm */ | |
| 233 must_flush = 1; | |
| 234 #endif | |
| 235 if (must_flush) | |
| 236 fflush (stream); | |
| 237 } | |
| 428 | 238 } |
| 239 else | |
| 771 | 240 /* The stream itself does conversion to external format */ |
| 241 Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream), ptr, len); | |
| 442 | 242 |
| 243 if (output_is_std_handle) | |
| 428 | 244 { |
| 245 if (termscript) | |
| 246 { | |
| 771 | 247 retry_fwrite (extptr, 1, extlen, termscript); |
| 428 | 248 fflush (termscript); |
| 249 } | |
| 1346 | 250 stdout_needs_newline = (ptr[len - 1] != '\n'); |
| 428 | 251 } |
| 252 } | |
| 253 | |
| 1346 | 254 /* Write to a stdio stream or TTY console, first clearing the left side |
| 255 if necessary. */ | |
| 256 | |
| 257 static void | |
| 258 write_string_to_stdio_stream (FILE *stream, struct console *con, | |
| 259 const Ibyte *ptr, Bytecount len, | |
| 260 int must_flush) | |
| 261 { | |
| 262 if (stdout_clear_before_next_output && | |
| 263 (stream ? stream == stdout || stream == stderr : | |
| 264 CONSOLE_TTY_DATA (con)->is_stdio)) | |
| 265 { | |
| 266 if (stdout_needs_newline) | |
| 267 write_string_to_stdio_stream_1 (stream, con, (Ibyte *) "\n", 1, | |
| 268 must_flush); | |
| 269 stdout_clear_before_next_output = 0; | |
| 270 } | |
| 271 | |
| 272 write_string_to_stdio_stream_1 (stream, con, ptr, len, must_flush); | |
| 273 } | |
| 274 | |
| 275 /* | |
| 276 EXT_PRINT_STDOUT = stdout or its equivalent (may be a | |
| 277 console window under MS Windows) | |
| 278 EXT_PRINT_STDERR = stderr or its equivalent (may be a | |
| 279 console window under MS Windows) | |
| 280 EXT_PRINT_ALTERNATE = an internal character array; see | |
| 281 `alternate-debugging-output' | |
| 282 EXT_PRINT_MSWINDOWS = Under MS Windows, the "debugging output" that | |
| 283 debuggers can hook into; uses OutputDebugString() | |
| 284 system call | |
| 285 EXT_PRINT_ALL = all of the above except stdout | |
| 286 */ | |
| 287 | |
| 288 enum ext_print | |
| 289 { | |
| 290 EXT_PRINT_STDOUT = 1, | |
| 291 EXT_PRINT_STDERR = 2, | |
| 292 EXT_PRINT_ALTERNATE = 4, | |
| 293 EXT_PRINT_MSWINDOWS = 8, | |
| 294 EXT_PRINT_ALL = 14 | |
| 295 }; | |
| 296 | |
| 297 static void | |
| 298 write_string_to_external_output (const Ibyte *ptr, Bytecount len, | |
| 299 int dest) | |
| 300 { | |
| 301 if (dest & EXT_PRINT_STDOUT) | |
| 302 write_string_to_stdio_stream (stdout, 0, ptr, len, 1); | |
| 303 if (dest & EXT_PRINT_STDERR) | |
| 304 write_string_to_stdio_stream (stderr, 0, ptr, len, 1); | |
| 305 if (dest & EXT_PRINT_ALTERNATE) | |
| 306 write_string_to_alternate_debugging_output (ptr, len); | |
| 307 #ifdef WIN32_NATIVE | |
| 308 if (dest & EXT_PRINT_MSWINDOWS) | |
| 309 write_string_to_mswindows_debugging_output (ptr, len); | |
| 310 #endif | |
| 311 } | |
| 312 | |
| 313 /* #### The following function should make use of a call to the | |
| 314 emacs_vsprintf_*() functions rather than just using vsprintf. This is | |
| 315 the only way to ensure that I18N3 works properly (many implementations | |
| 316 of the *printf() functions, including the ones included in glibc, do not | |
| 317 implement the %###$ argument-positioning syntax). | |
| 442 | 318 |
| 319 Note, however, that to do this, we'd have to | |
| 320 | |
| 321 1) pre-allocate all the lstreams and do whatever else was necessary | |
| 322 to make sure that no allocation occurs, since these functions may be | |
| 323 called from fatal_error_signal(). | |
| 324 | |
| 325 2) (to be really correct) make a new lstream that outputs using | |
| 1346 | 326 mswindows_output_console_string(). |
| 327 | |
| 328 3) A reasonable compromise might be to use emacs_vsprintf() when we're | |
| 329 in a safe state, and when not, use plain vsprintf(). */ | |
| 442 | 330 |
| 771 | 331 static void |
| 1346 | 332 write_string_to_external_output_va (const CIbyte *fmt, va_list args, |
| 333 int dest) | |
| 442 | 334 { |
| 867 | 335 Ibyte kludge[8192]; |
| 771 | 336 Bytecount kludgelen; |
| 337 | |
| 2367 | 338 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 339 fmt = GETTEXT (fmt); |
| 867 | 340 vsprintf ((CIbyte *) kludge, fmt, args); |
| 771 | 341 kludgelen = qxestrlen (kludge); |
| 1346 | 342 write_string_to_external_output (kludge, kludgelen, dest); |
| 442 | 343 } |
| 344 | |
| 771 | 345 /* Output portably to stderr or its equivalent (i.e. may be a console |
| 346 window under MS Windows); do external-format conversion and call GETTEXT | |
| 347 on the format string. Automatically flush when done. | |
| 442 | 348 |
| 2731 | 349 NOTE: CIbyte means "internal format" data. This includes the "..." |
| 350 arguments. For numerical arguments, we have to assume that vsprintf | |
| 351 will be a good boy and format them as ASCII. For Mule internal coding | |
| 352 (and UTF-8 internal coding, if/when we get it), it is safe to pass | |
| 353 string values in internal format to be formatted, because zero octets | |
| 354 only occur in the NUL character itself. Similarly, it is safe to pass | |
| 355 pure ASCII literal strings for these functions. *Everything else must | |
| 356 be converted, including all external data.* | |
| 357 | |
| 358 This function is safe to use even when not initialized or when dying -- | |
| 359 we don't do conversion in such cases. */ | |
| 771 | 360 |
| 361 void | |
| 867 | 362 stderr_out (const CIbyte *fmt, ...) |
| 442 | 363 { |
| 364 va_list args; | |
| 365 va_start (args, fmt); | |
| 1346 | 366 write_string_to_external_output_va (fmt, args, EXT_PRINT_STDERR); |
| 442 | 367 va_end (args); |
| 368 } | |
| 369 | |
| 771 | 370 /* Output portably to stdout or its equivalent (i.e. may be a console |
| 371 window under MS Windows). Works like stderr_out(). */ | |
| 442 | 372 |
| 771 | 373 void |
| 867 | 374 stdout_out (const CIbyte *fmt, ...) |
| 442 | 375 { |
| 376 va_list args; | |
| 377 va_start (args, fmt); | |
| 1346 | 378 write_string_to_external_output_va (fmt, args, EXT_PRINT_STDOUT); |
| 379 va_end (args); | |
| 380 } | |
| 381 | |
| 382 /* Output portably to print destination as specified by DEST. */ | |
| 383 | |
| 384 void | |
| 385 external_out (int dest, const CIbyte *fmt, ...) | |
| 386 { | |
| 387 va_list args; | |
| 388 va_start (args, fmt); | |
| 389 write_string_to_external_output_va (fmt, args, dest); | |
| 442 | 390 va_end (args); |
| 771 | 391 } |
| 392 | |
| 393 /* Output portably to stderr or its equivalent (i.e. may be a console | |
| 394 window under MS Windows), as well as alternate-debugging-output and | |
| 395 (under MS Windows) the C debugging output, i.e. OutputDebugString(). | |
| 396 Works like stderr_out(). */ | |
| 397 | |
| 398 void | |
| 867 | 399 debug_out (const CIbyte *fmt, ...) |
| 771 | 400 { |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
401 int depth = begin_inhibit_non_essential_conversion_operations (); |
| 771 | 402 va_list args; |
| 403 va_start (args, fmt); | |
| 1346 | 404 write_string_to_external_output_va (fmt, args, EXT_PRINT_ALL); |
| 771 | 405 va_end (args); |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
406 unbind_to (depth); |
| 442 | 407 } |
| 408 | |
| 409 DOESNT_RETURN | |
| 867 | 410 fatal (const CIbyte *fmt, ...) |
| 442 | 411 { |
| 412 va_list args; | |
| 413 va_start (args, fmt); | |
| 414 | |
| 771 | 415 stderr_out ("\nXEmacs: fatal error: "); |
| 1346 | 416 write_string_to_external_output_va (fmt, args, EXT_PRINT_STDERR); |
| 442 | 417 stderr_out ("\n"); |
| 418 | |
| 419 va_end (args); | |
| 420 exit (1); | |
| 421 } | |
| 422 | |
| 428 | 423 /* Write a string to the output location specified in FUNCTION. |
| 424 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in | |
| 771 | 425 buffer_insert_string_1() in insdel.c. |
| 426 | |
| 427 FUNCTION is one of | |
| 428 | |
| 429 -- an lstream | |
| 430 -- a buffer (insert at point and advance point) | |
| 431 -- a marker (insert at marker and advance marker) | |
| 432 -- a frame (append to echo area; clear echo area first if | |
| 433 `print-message-label' has changed since the last time) | |
| 434 -- t or nil (send to stdout) | |
| 435 -- a Lisp function of one argument (call to get data output) | |
| 436 | |
| 437 Use Qexternal_debugging_output to get output to stderr. | |
| 438 */ | |
| 428 | 439 |
| 440 static void | |
| 867 | 441 output_string (Lisp_Object function, const Ibyte *nonreloc, |
| 428 | 442 Lisp_Object reloc, Bytecount offset, Bytecount len) |
| 443 { | |
| 444 /* This function can GC */ | |
| 445 Charcount cclen; | |
| 446 /* We change the value of nonreloc (fetching it from reloc as | |
| 447 necessary), but we don't want to pass this changed value on to | |
| 448 other functions that take both a nonreloc and a reloc, or things | |
| 449 may get confused and an assertion failure in | |
| 450 fixup_internal_substring() may get triggered. */ | |
| 867 | 451 const Ibyte *newnonreloc = nonreloc; |
| 428 | 452 struct gcpro gcpro1, gcpro2; |
| 453 | |
| 454 /* Emacs won't print while GCing, but an external debugger might */ | |
| 771 | 455 #ifdef NO_PRINT_DURING_GC |
| 428 | 456 if (gc_in_progress) return; |
| 771 | 457 #endif |
| 428 | 458 |
| 459 /* Perhaps not necessary but probably safer. */ | |
| 460 GCPRO2 (function, reloc); | |
| 461 | |
| 462 fixup_internal_substring (newnonreloc, reloc, offset, &len); | |
| 463 | |
| 464 if (STRINGP (reloc)) | |
| 771 | 465 { |
| 793 | 466 cclen = string_offset_byte_to_char_len (reloc, offset, len); |
| 771 | 467 newnonreloc = XSTRING_DATA (reloc); |
| 468 } | |
| 469 else | |
| 470 cclen = bytecount_to_charcount (newnonreloc + offset, len); | |
| 428 | 471 |
| 472 if (LSTREAMP (function)) | |
| 473 { | |
| 474 if (STRINGP (reloc)) | |
| 475 { | |
| 476 /* Protect against Lstream_write() causing a GC and | |
| 477 relocating the string. For small strings, we do it by | |
| 478 alloc'ing the string and using a copy; for large strings, | |
| 479 we inhibit GC. */ | |
| 480 if (len < 65536) | |
| 481 { | |
| 2367 | 482 Ibyte *copied = alloca_ibytes (len); |
| 428 | 483 memcpy (copied, newnonreloc + offset, len); |
| 484 Lstream_write (XLSTREAM (function), copied, len); | |
| 485 } | |
| 1957 | 486 else if (gc_currently_forbidden) |
| 487 { | |
| 488 /* Avoid calling begin_gc_forbidden, which conses. We can reach | |
| 489 this point from the cons debug code, which will get us into | |
| 490 an infinite loop if we cons again. */ | |
| 491 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); | |
| 492 } | |
| 428 | 493 else |
| 494 { | |
| 771 | 495 int speccount = begin_gc_forbidden (); |
| 428 | 496 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); |
| 771 | 497 unbind_to (speccount); |
| 428 | 498 } |
| 499 } | |
| 500 else | |
| 501 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); | |
| 502 | |
| 503 if (print_unbuffered) | |
| 504 Lstream_flush (XLSTREAM (function)); | |
| 505 } | |
| 506 else if (BUFFERP (function)) | |
| 507 { | |
| 508 CHECK_LIVE_BUFFER (function); | |
| 509 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len); | |
| 510 } | |
| 511 else if (MARKERP (function)) | |
| 512 { | |
| 513 /* marker_position() will err if marker doesn't point anywhere. */ | |
| 665 | 514 Charbpos spoint = marker_position (function); |
| 428 | 515 |
| 516 buffer_insert_string_1 (XMARKER (function)->buffer, | |
| 517 spoint, nonreloc, reloc, offset, len, | |
|
5776
65d65b52d608
Pass character count from coding systems to buffer insertion code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5772
diff
changeset
|
518 -1, 0); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
519 Fset_marker (function, make_fixnum (spoint + cclen), |
| 428 | 520 Fmarker_buffer (function)); |
| 521 } | |
| 522 else if (FRAMEP (function)) | |
| 523 { | |
| 524 /* This gets used by functions not invoking print_prepare(), | |
| 525 such as Fwrite_char, Fterpri, etc.. */ | |
| 526 struct frame *f = XFRAME (function); | |
| 527 CHECK_LIVE_FRAME (function); | |
| 528 | |
| 529 if (!EQ (Vprint_message_label, echo_area_status (f))) | |
| 530 clear_echo_area_from_print (f, Qnil, 1); | |
| 531 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label); | |
| 532 } | |
| 533 else if (EQ (function, Qt) || EQ (function, Qnil)) | |
| 534 { | |
| 771 | 535 write_string_to_stdio_stream (stdout, 0, newnonreloc + offset, len, |
| 536 print_unbuffered); | |
| 537 } | |
| 538 else if (EQ (function, Qexternal_debugging_output)) | |
| 539 { | |
| 540 /* This is not strictly necessary, and somewhat of a hack, but it | |
| 541 avoids having each character passed separately to | |
| 542 `external-debugging-output'. #### Why do we pass each character | |
| 543 separately, anyway? | |
| 544 */ | |
| 545 write_string_to_stdio_stream (stderr, 0, newnonreloc + offset, len, | |
| 546 print_unbuffered); | |
| 428 | 547 } |
| 548 else | |
| 549 { | |
| 771 | 550 Charcount ccoff; |
| 428 | 551 Charcount iii; |
| 552 | |
| 771 | 553 if (STRINGP (reloc)) |
| 793 | 554 ccoff = string_index_byte_to_char (reloc, offset); |
| 771 | 555 else |
| 556 ccoff = bytecount_to_charcount (newnonreloc, offset); | |
| 557 | |
| 558 if (STRINGP (reloc)) | |
| 428 | 559 { |
| 771 | 560 for (iii = ccoff; iii < cclen + ccoff; iii++) |
| 561 { | |
| 867 | 562 call1 (function, make_char (string_ichar (reloc, iii))); |
| 771 | 563 if (STRINGP (reloc)) |
| 564 newnonreloc = XSTRING_DATA (reloc); | |
| 565 } | |
| 566 } | |
| 567 else | |
| 568 { | |
| 569 for (iii = ccoff; iii < cclen + ccoff; iii++) | |
| 570 { | |
| 571 call1 (function, | |
| 867 | 572 make_char (itext_ichar_n (newnonreloc, iii))); |
| 771 | 573 } |
| 428 | 574 } |
| 575 } | |
| 576 | |
| 577 UNGCPRO; | |
| 578 } | |
| 579 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
580 static int |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
581 print_continuous_numbering_changed (Lisp_Object UNUSED (sym), |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
582 Lisp_Object *val, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
583 Lisp_Object UNUSED (in_object), |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
584 int UNUSED (flags)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
585 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
586 if (!NILP (*val) && !print_continuous_numbering) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
587 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
588 Fclrhash (Vprint_number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
589 print_number_index = 0; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
590 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
591 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
592 return 0; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
593 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
594 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
595 #define RESET_PRINT_NUMBER_TABLE do { \ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
596 if (!print_continuous_numbering) \ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
597 { \ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
598 Fclrhash (Vprint_number_table); \ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
599 print_number_index = 0; \ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
600 } \ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
601 } while (0) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
602 |
| 1261 | 603 Lisp_Object |
| 428 | 604 canonicalize_printcharfun (Lisp_Object printcharfun) |
| 605 { | |
| 606 if (NILP (printcharfun)) | |
| 607 printcharfun = Vstandard_output; | |
| 608 | |
| 1261 | 609 if (!noninteractive && (EQ (printcharfun, Qt) || NILP (printcharfun))) |
| 428 | 610 printcharfun = Fselected_frame (Qnil); /* print to minibuffer */ |
| 611 | |
| 612 return printcharfun; | |
| 613 } | |
| 614 | |
| 615 static Lisp_Object | |
| 616 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) | |
| 617 { | |
| 618 /* Emacs won't print while GCing, but an external debugger might */ | |
| 771 | 619 #ifdef NO_PRINT_DURING_GC |
| 428 | 620 if (gc_in_progress) |
| 621 return Qnil; | |
| 771 | 622 #endif |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
623 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
624 RESET_PRINT_NUMBER_TABLE; |
| 428 | 625 |
| 626 printcharfun = canonicalize_printcharfun (printcharfun); | |
| 627 | |
| 628 /* Here we could safely return the canonicalized PRINTCHARFUN. | |
| 629 However, if PRINTCHARFUN is a frame, printing of complex | |
| 630 structures becomes very expensive, because `append-message' | |
| 631 (called by echo_area_append) gets called as many times as | |
| 632 output_string() is called (and that's a *lot*). append-message | |
| 633 tries to keep top of the message-stack in sync with the contents | |
| 634 of " *Echo Area" buffer, consing a new string for each component | |
| 635 of the printed structure. For instance, if you print (a a), | |
| 636 append-message will cons up the following strings: | |
| 637 | |
| 638 "(" | |
| 639 "(a" | |
| 640 "(a " | |
| 641 "(a a" | |
| 642 "(a a)" | |
| 643 | |
| 644 and will use only the last one. With larger objects, this turns | |
| 645 into an O(n^2) consing frenzy that locks up XEmacs in incessant | |
| 646 garbage collection. | |
| 647 | |
| 648 We prevent this by creating a resizing_buffer stream and letting | |
| 649 the printer write into it. print_finish() will notice this | |
| 650 stream, and invoke echo_area_append() with the stream's buffer, | |
| 651 only once. */ | |
| 652 if (FRAMEP (printcharfun)) | |
| 653 { | |
| 654 CHECK_LIVE_FRAME (printcharfun); | |
| 655 *frame_kludge = printcharfun; | |
| 656 printcharfun = make_resizing_buffer_output_stream (); | |
| 657 } | |
| 658 | |
| 659 return printcharfun; | |
| 660 } | |
| 661 | |
| 662 static void | |
| 663 print_finish (Lisp_Object stream, Lisp_Object frame_kludge) | |
| 664 { | |
| 665 /* Emacs won't print while GCing, but an external debugger might */ | |
| 771 | 666 #ifdef NO_PRINT_DURING_GC |
| 428 | 667 if (gc_in_progress) |
| 668 return; | |
| 771 | 669 #endif |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
670 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
671 RESET_PRINT_NUMBER_TABLE; |
| 428 | 672 |
| 673 /* See the comment in print_prepare(). */ | |
| 674 if (FRAMEP (frame_kludge)) | |
| 675 { | |
| 676 struct frame *f = XFRAME (frame_kludge); | |
| 677 Lstream *str = XLSTREAM (stream); | |
| 678 CHECK_LIVE_FRAME (frame_kludge); | |
| 679 | |
| 680 Lstream_flush (str); | |
| 681 if (!EQ (Vprint_message_label, echo_area_status (f))) | |
| 682 clear_echo_area_from_print (f, Qnil, 1); | |
| 683 echo_area_append (f, resizing_buffer_stream_ptr (str), | |
| 684 Qnil, 0, Lstream_byte_count (str), | |
| 685 Vprint_message_label); | |
| 686 Lstream_delete (str); | |
| 687 } | |
| 688 } | |
| 689 | |
| 690 | |
| 771 | 691 /* Write internal-format data to STREAM. See output_string() for |
| 692 interpretation of STREAM. | |
| 693 | |
| 694 NOTE: Do not call this with the data of a Lisp_String, as | |
| 428 | 695 printcharfun might cause a GC, which might cause the string's data |
| 696 to be relocated. To princ a Lisp string, use: | |
| 697 | |
| 698 print_internal (string, printcharfun, 0); | |
| 699 | |
| 700 Also note that STREAM should be the result of | |
| 701 canonicalize_printcharfun() (i.e. Qnil means stdout, not | |
| 702 Vstandard_output, etc.) */ | |
| 703 void | |
| 867 | 704 write_string_1 (Lisp_Object stream, const Ibyte *str, Bytecount size) |
| 428 | 705 { |
| 706 /* This function can GC */ | |
| 800 | 707 #ifdef ERROR_CHECK_TEXT |
| 428 | 708 assert (size >= 0); |
| 709 #endif | |
| 710 output_string (stream, str, Qnil, 0, size); | |
| 711 } | |
| 712 | |
| 713 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
714 write_istring (Lisp_Object stream, const Ibyte *str) |
| 771 | 715 { |
| 716 /* This function can GC */ | |
| 826 | 717 write_string_1 (stream, str, qxestrlen (str)); |
| 771 | 718 } |
| 719 | |
| 720 void | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
721 write_cistring (Lisp_Object stream, const CIbyte *str) |
| 428 | 722 { |
| 723 /* This function can GC */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
724 write_istring (stream, (const Ibyte *) str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
725 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
726 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
727 void |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
728 write_ascstring (Lisp_Object stream, const Ascbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
729 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
730 /* This function can GC */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
731 ASSERT_ASCTEXT_ASCII (str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
732 write_istring (stream, (const Ibyte *) str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
733 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
734 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
735 void |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
736 write_msg_istring (Lisp_Object stream, const Ibyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
737 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
738 /* This function can GC */ |
| 4973 | 739 write_istring (stream, IGETTEXT (str)); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
740 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
741 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
742 void |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
743 write_msg_cistring (Lisp_Object stream, const CIbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
744 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
745 /* This function can GC */ |
| 4973 | 746 write_msg_istring (stream, (const Ibyte *) str); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
747 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
748 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
749 void |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
750 write_msg_ascstring (Lisp_Object stream, const Ascbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
751 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
752 /* This function can GC */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
753 ASSERT_ASCTEXT_ASCII (str); |
| 4973 | 754 write_msg_istring (stream, (const Ibyte *) str); |
| 428 | 755 } |
| 756 | |
| 793 | 757 void |
| 826 | 758 write_eistring (Lisp_Object stream, const Eistring *ei) |
| 793 | 759 { |
| 826 | 760 write_string_1 (stream, eidata (ei), eilen (ei)); |
| 793 | 761 } |
| 762 | |
| 771 | 763 /* Write a printf-style string to STREAM; see output_string(). */ |
| 764 | |
| 765 void | |
| 867 | 766 write_fmt_string (Lisp_Object stream, const CIbyte *fmt, ...) |
| 771 | 767 { |
| 768 va_list va; | |
| 867 | 769 Ibyte *str; |
| 771 | 770 Bytecount len; |
| 771 int count; | |
| 772 | |
| 773 va_start (va, fmt); | |
| 774 str = emacs_vsprintf_malloc (fmt, va, &len); | |
| 775 va_end (va); | |
| 776 count = record_unwind_protect_freeing (str); | |
| 826 | 777 write_string_1 (stream, str, len); |
| 771 | 778 unbind_to (count); |
| 779 } | |
| 780 | |
| 781 /* Write a printf-style string to STREAM, where the arguments are | |
| 782 Lisp objects and not C strings or integers; see output_string(). | |
| 783 | |
| 784 #### It shouldn't be necessary to specify the number of arguments. | |
| 785 This would require some rewriting of the doprnt() functions, though. */ | |
| 786 | |
| 787 void | |
| 867 | 788 write_fmt_string_lisp (Lisp_Object stream, const CIbyte *fmt, int nargs, ...) |
| 771 | 789 { |
| 790 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 791 va_list va; | |
| 792 int i; | |
| 867 | 793 Ibyte *str; |
| 771 | 794 Bytecount len; |
| 795 int count; | |
| 796 | |
| 797 va_start (va, nargs); | |
| 798 for (i = 0; i < nargs; i++) | |
| 799 args[i] = va_arg (va, Lisp_Object); | |
| 800 va_end (va); | |
| 801 str = emacs_vsprintf_malloc_lisp (fmt, Qnil, nargs, args, &len); | |
| 802 count = record_unwind_protect_freeing (str); | |
| 826 | 803 write_string_1 (stream, str, len); |
| 771 | 804 unbind_to (count); |
| 805 } | |
| 806 | |
| 807 void | |
| 867 | 808 stderr_out_lisp (const CIbyte *fmt, int nargs, ...) |
| 771 | 809 { |
| 810 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 811 va_list va; | |
| 812 int i; | |
| 867 | 813 Ibyte *str; |
| 771 | 814 Bytecount len; |
| 815 int count; | |
| 816 | |
| 817 va_start (va, nargs); | |
| 818 for (i = 0; i < nargs; i++) | |
| 819 args[i] = va_arg (va, Lisp_Object); | |
| 820 va_end (va); | |
| 821 str = emacs_vsprintf_malloc_lisp (fmt, Qnil, nargs, args, &len); | |
| 822 count = record_unwind_protect_freeing (str); | |
| 826 | 823 write_string_1 (Qexternal_debugging_output, str, len); |
| 771 | 824 unbind_to (count); |
| 825 } | |
| 826 | |
| 428 | 827 |
| 828 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /* | |
| 444 | 829 Output character CHARACTER to stream STREAM. |
| 428 | 830 STREAM defaults to the value of `standard-output' (which see). |
| 831 */ | |
| 444 | 832 (character, stream)) |
| 428 | 833 { |
| 834 /* This function can GC */ | |
| 867 | 835 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 836 Bytecount len; |
| 837 | |
| 444 | 838 CHECK_CHAR_COERCE_INT (character); |
| 867 | 839 len = set_itext_ichar (str, XCHAR (character)); |
| 428 | 840 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len); |
| 444 | 841 return character; |
| 428 | 842 } |
| 843 | |
|
5772
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
844 DEFUN ("write-sequence", Fwrite_sequence, 1, MANY, 0, /* |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
845 Output string, list, vector or bit-vector SEQUENCE to STREAM. |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
846 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
847 STREAM defaults to the value of `standard-output', which see. |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
848 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
849 Keywords :start and :end, if given, specify indices of a subsequence |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
850 of SEQUENCE to output. They default to 0 and nil, meaning write the |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
851 entire sequence. |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
852 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
853 Elements of SEQUENCE can be characters (all are accepted by this function, |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
854 though they may be corrupted depending on the coding system associated with |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
855 STREAM) or integers below #x100, which are treated as equivalent to the |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
856 characters with the corresponding code. This function is from Common Lisp, |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
857 rather GNU Emacs API, so GNU Emacs' character-integer equivalence doesn't |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
858 hold. |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
859 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
860 Returns SEQUENCE (not the subsequence of SEQUENCE that has been written to |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
861 STREAM). |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
862 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
863 arguments: (SEQUENCE &optional STREAM &key (START 0) END) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
864 */ |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
865 (int nargs, Lisp_Object *args)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
866 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
867 Lisp_Object sequence = args[0], stream = (nargs > 1) ? args[1] : Qnil; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
868 Lisp_Object reloc = Qnil; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
869 Charcount starting = 0, ending = 1 + MOST_POSITIVE_FIXNUM; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
870 Ibyte *nonreloc = NULL, *all = NULL, *allptr = all; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
871 Bytecount bstart = 0, blen = 0; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
872 Elemcount ii = 0; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
873 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
874 PARSE_KEYWORDS_8 (Qwrite_sequence, nargs, args, 2, (start, end), |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
875 (start = Qzero), 2, 0); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
876 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
877 CHECK_SEQUENCE (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
878 CHECK_NATNUM (start); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
879 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
880 if (!NILP (end)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
881 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
882 CHECK_NATNUM (end); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
883 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
884 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
885 stream = canonicalize_printcharfun (stream); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
886 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
887 if (BIGNUMP (start) || (BIGNUMP (end))) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
888 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
889 /* None of the sequences will have bignum lengths. */ |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
890 check_sequence_range (sequence, start, end, Flength (sequence)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
891 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
892 RETURN_NOT_REACHED (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
893 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
894 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
895 starting = XFIXNUM (start); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
896 if (FIXNUMP (end)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
897 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
898 ending = XFIXNUM (end); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
899 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
900 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
901 if (STRINGP (sequence)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
902 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
903 Ibyte *stringp = XSTRING_DATA (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
904 Ibyte *strend = stringp + XSTRING_LENGTH (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
905 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
906 reloc = sequence; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
907 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
908 for (ii = 0; ii < starting && stringp < strend; ++ii) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
909 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
910 INC_IBYTEPTR (stringp); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
911 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
912 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
913 if (ii != starting) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
914 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
915 /* Bad value for start. */ |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
916 check_sequence_range (sequence, start, end, |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
917 Flength (sequence)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
918 RETURN_NOT_REACHED (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
919 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
920 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
921 bstart = stringp - XSTRING_DATA (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
922 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
923 for (; ii < ending && stringp < strend; ++ii) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
924 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
925 INC_IBYTEPTR (stringp); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
926 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
927 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
928 if (ii != ending && ending != (1 + MOST_POSITIVE_FIXNUM)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
929 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
930 /* Bad value for end. */ |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
931 check_sequence_range (sequence, start, end, |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
932 Flength (sequence)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
933 RETURN_NOT_REACHED (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
934 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
935 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
936 blen = stringp - (XSTRING_DATA (sequence) + bstart); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
937 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
938 else |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
939 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
940 Lisp_Object length = Flength (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
941 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
942 check_sequence_range (sequence, start, end, length); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
943 ending = NILP (end) ? XFIXNUM (length) : XFIXNUM (end); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
944 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
945 if (VECTORP (sequence)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
946 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
947 Lisp_Object *vdata = XVECTOR_DATA (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
948 /* Worst case scenario; all characters, all the longest possible. More |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
949 likely: lots of small integers. */ |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
950 nonreloc = allptr |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
951 = alloca_ibytes (((ending - starting)) * MAX_ICHAR_LEN); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
952 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
953 for (ii = starting; ii < ending; ++ii) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
954 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
955 if (!CHARP (vdata[ii])) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
956 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
957 check_integer_range (vdata[ii], Qzero, make_fixnum (0xff)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
958 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
959 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
960 allptr += set_itext_ichar (allptr, |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
961 XCHAR_OR_CHAR_INT (vdata[ii])); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
962 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
963 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
964 else if (CONSP (sequence)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
965 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
966 /* Worst case scenario; all characters, all the longest |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
967 possible. More likely: lots of small integers. */ |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
968 nonreloc = allptr |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
969 = alloca_ibytes (((ending - starting)) * MAX_ICHAR_LEN); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
970 ii = 0; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
971 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
972 EXTERNAL_LIST_LOOP_2 (elt, sequence) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
973 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
974 if (ii >= starting) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
975 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
976 if (ii >= ending) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
977 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
978 break; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
979 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
980 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
981 if (!CHARP (elt)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
982 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
983 check_integer_range (elt, Qzero, make_fixnum (0xff)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
984 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
985 allptr += set_itext_ichar (allptr, |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
986 XCHAR_OR_CHAR_INT (elt)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
987 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
988 ++ii; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
989 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
990 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
991 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
992 else if (BIT_VECTORP (sequence)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
993 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
994 Ibyte one [MAX_ICHAR_LEN]; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
995 Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
996 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
997 nonreloc = allptr |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
998 = alloca_ibytes (((ending - starting) * |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
999 (set_itext_ichar (one, (Ichar)1)))); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1000 for (ii = starting; ii < ending; ++ii) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1001 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1002 allptr += set_itext_ichar (allptr, bit_vector_bit (vv, ii)); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1003 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1004 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1005 else if (NILP (sequence)) |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1006 { |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1007 nonreloc = allptr = alloca_ibytes (1); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1008 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1009 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1010 bstart = 0; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1011 blen = allptr - nonreloc; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1012 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1013 |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1014 output_string (stream, nonreloc, reloc, bstart, blen); |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1015 return sequence; |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1016 } |
|
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
1017 |
| 428 | 1018 void |
| 1019 temp_output_buffer_setup (Lisp_Object bufname) | |
| 1020 { | |
| 1021 /* This function can GC */ | |
| 1022 struct buffer *old = current_buffer; | |
| 1023 Lisp_Object buf; | |
| 1024 | |
| 1025 #ifdef I18N3 | |
| 1026 /* #### This function should accept a Lisp_Object instead of a char *, | |
| 1027 so that proper translation on the buffer name can occur. */ | |
| 1028 #endif | |
| 1029 | |
| 1030 Fset_buffer (Fget_buffer_create (bufname)); | |
| 1031 | |
| 1032 current_buffer->read_only = Qnil; | |
| 1033 Ferase_buffer (Qnil); | |
| 1034 | |
| 793 | 1035 buf = wrap_buffer (current_buffer); |
| 428 | 1036 specbind (Qstandard_output, buf); |
| 1037 | |
| 1038 set_buffer_internal (old); | |
| 1039 } | |
| 1040 | |
| 1041 Lisp_Object | |
| 1042 internal_with_output_to_temp_buffer (Lisp_Object bufname, | |
| 1043 Lisp_Object (*function) (Lisp_Object arg), | |
| 1044 Lisp_Object arg, | |
| 1045 Lisp_Object same_frame) | |
| 1046 { | |
| 1047 int speccount = specpdl_depth (); | |
| 1048 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 1049 Lisp_Object buf = Qnil; | |
| 1050 | |
| 1051 GCPRO3 (buf, arg, same_frame); | |
| 1052 | |
| 1053 temp_output_buffer_setup (bufname); | |
| 1054 buf = Vstandard_output; | |
| 1055 | |
| 1056 arg = (*function) (arg); | |
| 1057 | |
| 1058 temp_output_buffer_show (buf, same_frame); | |
| 1059 UNGCPRO; | |
| 1060 | |
| 771 | 1061 return unbind_to_1 (speccount, arg); |
| 428 | 1062 } |
| 1063 | |
| 1064 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /* | |
| 1065 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. | |
| 1066 The buffer is cleared out initially, and marked as unmodified when done. | |
| 1067 All output done by BODY is inserted in that buffer by default. | |
| 1068 The buffer is displayed in another window, but not selected. | |
| 1069 The value of the last form in BODY is returned. | |
| 1070 If BODY does not finish normally, the buffer BUFNAME is not displayed. | |
| 1071 | |
| 1072 If variable `temp-buffer-show-function' is non-nil, call it at the end | |
| 1073 to get the buffer displayed. It gets one argument, the buffer to display. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
1074 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
1075 arguments: (BUFNAME &rest BODY) |
| 428 | 1076 */ |
| 1077 (args)) | |
| 1078 { | |
| 1079 /* This function can GC */ | |
| 1080 Lisp_Object name = Qnil; | |
| 1081 int speccount = specpdl_depth (); | |
| 1082 struct gcpro gcpro1, gcpro2; | |
| 1083 Lisp_Object val = Qnil; | |
| 1084 | |
| 1085 #ifdef I18N3 | |
| 1086 /* #### should set the buffer to be translating. See print_internal(). */ | |
| 1087 #endif | |
| 1088 | |
| 1089 GCPRO2 (name, val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4528
diff
changeset
|
1090 name = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
| 428 | 1091 |
| 1092 CHECK_STRING (name); | |
| 1093 | |
| 1094 temp_output_buffer_setup (name); | |
| 1095 UNGCPRO; | |
| 1096 | |
| 1097 val = Fprogn (XCDR (args)); | |
| 1098 | |
| 1099 temp_output_buffer_show (Vstandard_output, Qnil); | |
| 1100 | |
| 771 | 1101 return unbind_to_1 (speccount, val); |
| 428 | 1102 } |
| 1103 | |
| 1104 DEFUN ("terpri", Fterpri, 0, 1, 0, /* | |
| 1105 Output a newline to STREAM. | |
| 1106 If STREAM is omitted or nil, the value of `standard-output' is used. | |
| 1107 */ | |
| 1108 (stream)) | |
| 1109 { | |
| 1110 /* This function can GC */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1111 write_ascstring (canonicalize_printcharfun (stream), "\n"); |
| 428 | 1112 return Qt; |
| 1113 } | |
| 1114 | |
| 1115 DEFUN ("prin1", Fprin1, 1, 2, 0, /* | |
| 1116 Output the printed representation of OBJECT, any Lisp object. | |
| 1117 Quoting characters are printed when needed to make output that `read' | |
| 1118 can handle, whenever this is possible. | |
| 1119 Output stream is STREAM, or value of `standard-output' (which see). | |
| 1120 */ | |
| 1121 (object, stream)) | |
| 1122 { | |
| 1123 /* This function can GC */ | |
| 1124 Lisp_Object frame = Qnil; | |
| 1125 struct gcpro gcpro1, gcpro2; | |
| 1126 GCPRO2 (object, stream); | |
| 1127 | |
| 1128 stream = print_prepare (stream, &frame); | |
| 1129 print_internal (object, stream, 1); | |
| 1130 print_finish (stream, frame); | |
| 1131 | |
| 1132 UNGCPRO; | |
| 1133 return object; | |
| 1134 } | |
| 1135 | |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1136 Lisp_Object |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1137 prin1_to_string (Lisp_Object object, int noescape) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1138 { |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1139 /* This function can GC */ |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1140 Lisp_Object result = Qnil; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1141 Lisp_Object stream = make_resizing_buffer_output_stream (); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1142 Lstream *str = XLSTREAM (stream); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1143 /* gcpro OBJECT in case a caller forgot to do so */ |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1144 struct gcpro gcpro1, gcpro2, gcpro3; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1145 GCPRO3 (object, stream, result); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1146 |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1147 print_internal (object, stream, !noescape); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1148 Lstream_flush (str); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1149 UNGCPRO; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1150 result = make_string (resizing_buffer_stream_ptr (str), |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1151 Lstream_byte_count (str)); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1152 Lstream_delete (str); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1153 return result; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1154 } |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1155 |
| 428 | 1156 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /* |
| 1157 Return a string containing the printed representation of OBJECT, | |
| 1158 any Lisp object. Quoting characters are used when needed to make output | |
| 1159 that `read' can handle, whenever this is possible, unless the optional | |
| 1160 second argument NOESCAPE is non-nil. | |
| 1161 */ | |
| 1162 (object, noescape)) | |
| 1163 { | |
| 1164 /* This function can GC */ | |
| 1165 Lisp_Object result = Qnil; | |
| 1166 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1167 RESET_PRINT_NUMBER_TABLE; |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1168 result = prin1_to_string (object, !(EQ(noescape, Qnil))); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1169 RESET_PRINT_NUMBER_TABLE; |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
1170 |
| 428 | 1171 return result; |
| 1172 } | |
| 1173 | |
| 1174 DEFUN ("princ", Fprinc, 1, 2, 0, /* | |
| 1175 Output the printed representation of OBJECT, any Lisp object. | |
| 1176 No quoting characters are used; no delimiters are printed around | |
| 1177 the contents of strings. | |
| 444 | 1178 Output stream is STREAM, or value of `standard-output' (which see). |
| 428 | 1179 */ |
| 1180 (object, stream)) | |
| 1181 { | |
| 1182 /* This function can GC */ | |
| 1183 Lisp_Object frame = Qnil; | |
| 1184 struct gcpro gcpro1, gcpro2; | |
| 1185 | |
| 1186 GCPRO2 (object, stream); | |
| 1187 stream = print_prepare (stream, &frame); | |
| 1188 print_internal (object, stream, 0); | |
| 1189 print_finish (stream, frame); | |
| 1190 UNGCPRO; | |
| 1191 return object; | |
| 1192 } | |
| 1193 | |
| 1194 DEFUN ("print", Fprint, 1, 2, 0, /* | |
| 1195 Output the printed representation of OBJECT, with newlines around it. | |
| 1196 Quoting characters are printed when needed to make output that `read' | |
| 1197 can handle, whenever this is possible. | |
| 1198 Output stream is STREAM, or value of `standard-output' (which see). | |
| 1199 */ | |
| 1200 (object, stream)) | |
| 1201 { | |
| 1202 /* This function can GC */ | |
| 1203 Lisp_Object frame = Qnil; | |
| 1204 struct gcpro gcpro1, gcpro2; | |
| 1205 | |
| 1206 GCPRO2 (object, stream); | |
| 1207 stream = print_prepare (stream, &frame); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1208 write_ascstring (stream, "\n"); |
| 428 | 1209 print_internal (object, stream, 1); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1210 write_ascstring (stream, "\n"); |
| 428 | 1211 print_finish (stream, frame); |
| 1212 UNGCPRO; | |
| 1213 return object; | |
| 1214 } | |
| 1215 | |
| 1216 /* Print an error message for the error DATA to STREAM. This is a | |
| 1217 complete implementation of `display-error', which used to be in | |
| 1218 Lisp (see prim/cmdloop.el). It was ported to C so it can be used | |
| 1219 efficiently by Ferror_message_string. Fdisplay_error and | |
| 1220 Ferror_message_string are trivial wrappers around this function. | |
| 1221 | |
| 1222 STREAM should be the result of canonicalize_printcharfun(). */ | |
| 1223 static void | |
| 1224 print_error_message (Lisp_Object error_object, Lisp_Object stream) | |
| 1225 { | |
| 1226 /* This function can GC */ | |
| 1227 Lisp_Object type = Fcar_safe (error_object); | |
| 1228 Lisp_Object method = Qnil; | |
| 1229 Lisp_Object tail; | |
| 1230 | |
| 1231 /* No need to GCPRO anything under the assumption that ERROR_OBJECT | |
| 1232 is GCPRO'd. */ | |
| 1233 | |
| 1234 if (! (CONSP (error_object) && SYMBOLP (type) | |
| 1235 && CONSP (Fget (type, Qerror_conditions, Qnil)))) | |
| 1236 goto error_throw; | |
| 1237 | |
| 1238 tail = XCDR (error_object); | |
| 1239 while (!NILP (tail)) | |
| 1240 { | |
| 1241 if (CONSP (tail)) | |
| 1242 tail = XCDR (tail); | |
| 1243 else | |
| 1244 goto error_throw; | |
| 1245 } | |
| 1246 tail = Fget (type, Qerror_conditions, Qnil); | |
| 1247 while (!NILP (tail)) | |
| 1248 { | |
| 1249 if (!(CONSP (tail) && SYMBOLP (XCAR (tail)))) | |
| 1250 goto error_throw; | |
| 1251 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil))) | |
| 1252 { | |
| 1253 method = Fget (XCAR (tail), Qdisplay_error, Qnil); | |
| 1254 goto error_throw; | |
| 1255 } | |
| 1256 else | |
| 1257 tail = XCDR (tail); | |
| 1258 } | |
| 1259 /* Default method */ | |
| 1260 { | |
| 1261 int first = 1; | |
| 1262 int speccount = specpdl_depth (); | |
| 438 | 1263 Lisp_Object frame = Qnil; |
| 1264 struct gcpro gcpro1; | |
| 1265 GCPRO1 (stream); | |
| 428 | 1266 |
| 1267 specbind (Qprint_message_label, Qerror); | |
| 438 | 1268 stream = print_prepare (stream, &frame); |
| 1269 | |
| 428 | 1270 tail = Fcdr (error_object); |
| 1271 if (EQ (type, Qerror)) | |
| 1272 { | |
| 1273 print_internal (Fcar (tail), stream, 0); | |
| 1274 tail = Fcdr (tail); | |
| 1275 } | |
| 1276 else | |
| 1277 { | |
| 1278 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil); | |
| 1279 if (NILP (errmsg)) | |
| 1280 print_internal (type, stream, 0); | |
| 1281 else | |
| 1282 print_internal (LISP_GETTEXT (errmsg), stream, 0); | |
| 1283 } | |
| 1284 while (!NILP (tail)) | |
| 1285 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1286 write_ascstring (stream, first ? ": " : ", "); |
| 563 | 1287 /* Most errors have an explanatory string as their first argument, |
| 1288 and it looks better not to put the quotes around it. */ | |
| 1289 print_internal (Fcar (tail), stream, | |
| 1290 !(first && STRINGP (Fcar (tail))) || | |
| 1291 !NILP (Fget (type, Qerror_lacks_explanatory_string, | |
| 1292 Qnil))); | |
| 428 | 1293 tail = Fcdr (tail); |
| 1294 first = 0; | |
| 1295 } | |
| 438 | 1296 print_finish (stream, frame); |
| 1297 UNGCPRO; | |
| 771 | 1298 unbind_to (speccount); |
| 428 | 1299 return; |
| 1300 /* not reached */ | |
| 1301 } | |
| 1302 | |
| 1303 error_throw: | |
| 1304 if (NILP (method)) | |
| 1305 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1306 write_ascstring (stream, GETTEXT ("Peculiar error ")); |
| 428 | 1307 print_internal (error_object, stream, 1); |
| 1308 return; | |
| 1309 } | |
| 1310 else | |
| 1311 { | |
| 1312 call2 (method, error_object, stream); | |
| 1313 } | |
| 1314 } | |
| 1315 | |
| 1316 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /* | |
| 1317 Convert ERROR-OBJECT to an error message, and return it. | |
| 1318 | |
| 1319 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The | |
| 1320 message is equivalent to the one that would be issued by | |
| 1321 `display-error' with the same argument. | |
| 1322 */ | |
| 1323 (error_object)) | |
| 1324 { | |
| 1325 /* This function can GC */ | |
| 1326 Lisp_Object result = Qnil; | |
| 1327 Lisp_Object stream = make_resizing_buffer_output_stream (); | |
| 1328 struct gcpro gcpro1; | |
| 1329 GCPRO1 (stream); | |
| 1330 | |
| 1331 print_error_message (error_object, stream); | |
| 1332 Lstream_flush (XLSTREAM (stream)); | |
| 1333 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)), | |
| 1334 Lstream_byte_count (XLSTREAM (stream))); | |
| 1335 Lstream_delete (XLSTREAM (stream)); | |
| 1336 | |
| 1337 UNGCPRO; | |
| 1338 return result; | |
| 1339 } | |
| 1340 | |
| 1341 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /* | |
| 1342 Display ERROR-OBJECT on STREAM in a user-friendly way. | |
| 1343 */ | |
| 1344 (error_object, stream)) | |
| 1345 { | |
| 1346 /* This function can GC */ | |
| 1347 print_error_message (error_object, canonicalize_printcharfun (stream)); | |
| 1348 return Qnil; | |
| 1349 } | |
| 1350 | |
| 1351 | |
| 1352 Lisp_Object Vfloat_output_format; | |
| 1353 | |
| 1354 /* | |
| 1355 * This buffer should be at least as large as the max string size of the | |
| 440 | 1356 * largest float, printed in the biggest notation. This is undoubtedly |
| 428 | 1357 * 20d float_output_format, with the negative of the C-constant "HUGE" |
| 1358 * from <math.h>. | |
| 1359 * | |
| 1360 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes. | |
| 1361 * | |
| 1362 * I assume that IEEE-754 format numbers can take 329 bytes for the worst | |
| 1363 * case of -1e307 in 20d float_output_format. What is one to do (short of | |
| 1364 * re-writing _doprnt to be more sane)? | |
| 1365 * -wsr | |
| 1366 */ | |
| 1367 void | |
| 1368 float_to_string (char *buf, double data) | |
| 1369 { | |
| 867 | 1370 Ibyte *cp, c; |
| 428 | 1371 int width; |
| 1372 | |
| 1373 if (NILP (Vfloat_output_format) | |
| 1374 || !STRINGP (Vfloat_output_format)) | |
| 1375 lose: | |
| 1376 sprintf (buf, "%.16g", data); | |
| 1377 else /* oink oink */ | |
| 1378 { | |
| 1379 /* Check that the spec we have is fully valid. | |
| 1380 This means not only valid for printf, | |
| 1381 but meant for floats, and reasonable. */ | |
| 1382 cp = XSTRING_DATA (Vfloat_output_format); | |
| 1383 | |
| 1384 if (cp[0] != '%') | |
| 1385 goto lose; | |
| 1386 if (cp[1] != '.') | |
| 1387 goto lose; | |
| 1388 | |
| 1389 cp += 2; | |
| 1390 for (width = 0; (c = *cp, isdigit (c)); cp++) | |
| 1391 { | |
| 1392 width *= 10; | |
| 1393 width += c - '0'; | |
| 1394 } | |
| 1395 | |
| 1396 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G') | |
| 1397 goto lose; | |
| 1398 | |
| 1399 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG) | |
| 1400 goto lose; | |
| 1401 | |
| 1402 if (cp[1] != 0) | |
| 1403 goto lose; | |
| 1404 | |
| 1405 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format), | |
| 1406 data); | |
| 1407 } | |
| 1408 | |
| 1409 /* added by jwz: don't allow "1.0" to print as "1"; that destroys | |
| 1410 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do | |
| 1411 not do the same thing, so it's important that the printed | |
| 1412 representation of that form not be corrupted by the printer. | |
| 1413 */ | |
| 1414 { | |
| 867 | 1415 Ibyte *s = (Ibyte *) buf; /* don't use signed chars here! |
| 428 | 1416 isdigit() can't hack them! */ |
| 1417 if (*s == '-') s++; | |
| 1418 for (; *s; s++) | |
| 1419 /* if there's a non-digit, then there is a decimal point, or | |
| 1420 it's in exponential notation, both of which are ok. */ | |
| 1421 if (!isdigit (*s)) | |
| 1422 goto DONE_LABEL; | |
| 1423 /* otherwise, we need to hack it. */ | |
| 1424 *s++ = '.'; | |
| 1425 *s++ = '0'; | |
| 1426 *s = 0; | |
| 1427 } | |
| 1428 DONE_LABEL: | |
| 1429 | |
| 1430 /* Some machines print "0.4" as ".4". I don't like that. */ | |
| 1431 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.')) | |
| 1432 { | |
| 1433 int i; | |
| 1434 for (i = strlen (buf) + 1; i >= 0; i--) | |
| 1435 buf [i+1] = buf [i]; | |
| 1436 buf [(buf [0] == '-' ? 1 : 0)] = '0'; | |
| 1437 } | |
| 1438 } | |
| 1439 | |
| 2500 | 1440 #define ONE_DIGIT(figure) *p++ = (char) (n / (figure) + '0') |
| 577 | 1441 #define ONE_DIGIT_ADVANCE(figure) (ONE_DIGIT (figure), n %= (figure)) |
| 1442 | |
| 1443 #define DIGITS_1(figure) ONE_DIGIT (figure) | |
| 1444 #define DIGITS_2(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_1 ((figure) / 10) | |
| 1445 #define DIGITS_3(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_2 ((figure) / 10) | |
| 1446 #define DIGITS_4(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_3 ((figure) / 10) | |
| 1447 #define DIGITS_5(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_4 ((figure) / 10) | |
| 1448 #define DIGITS_6(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_5 ((figure) / 10) | |
| 1449 #define DIGITS_7(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_6 ((figure) / 10) | |
| 1450 #define DIGITS_8(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_7 ((figure) / 10) | |
| 1451 #define DIGITS_9(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_8 ((figure) / 10) | |
| 1452 #define DIGITS_10(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_9 ((figure) / 10) | |
| 1453 | |
| 1454 /* DIGITS_<11-20> are only used on machines with 64-bit longs. */ | |
| 428 | 1455 |
| 577 | 1456 #define DIGITS_11(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_10 ((figure) / 10) |
| 1457 #define DIGITS_12(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_11 ((figure) / 10) | |
| 1458 #define DIGITS_13(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_12 ((figure) / 10) | |
| 1459 #define DIGITS_14(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_13 ((figure) / 10) | |
| 1460 #define DIGITS_15(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_14 ((figure) / 10) | |
| 1461 #define DIGITS_16(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_15 ((figure) / 10) | |
| 1462 #define DIGITS_17(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_16 ((figure) / 10) | |
| 1463 #define DIGITS_18(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_17 ((figure) / 10) | |
| 1464 #define DIGITS_19(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_18 ((figure) / 10) | |
| 1465 | |
| 1466 /* Print NUMBER to BUFFER in base 10. This is completely equivalent | |
| 1467 to `sprintf(buffer, "%ld", number)', only much faster. | |
| 1468 | |
| 1469 The speedup may make a difference in programs that frequently | |
| 1470 convert numbers to strings. Some implementations of sprintf, | |
| 1471 particularly the one in GNU libc, have been known to be extremely | |
| 1472 slow compared to this function. | |
| 1473 | |
| 1474 BUFFER should accept as many bytes as you expect the number to take | |
| 1475 up. On machines with 64-bit longs the maximum needed size is 24 | |
| 1476 bytes. That includes the worst-case digits, the optional `-' sign, | |
| 1477 and the trailing \0. */ | |
| 1478 | |
| 1479 void | |
| 428 | 1480 long_to_string (char *buffer, long number) |
| 1481 { | |
| 577 | 1482 char *p = buffer; |
| 1483 long n = number; | |
| 1484 | |
| 428 | 1485 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8) |
| 577 | 1486 /* We are running in a strange or misconfigured environment. Let |
| 1487 sprintf cope with it. */ | |
| 1488 sprintf (buffer, "%ld", n); | |
| 1489 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ | |
| 428 | 1490 |
| 577 | 1491 if (n < 0) |
| 428 | 1492 { |
| 1493 *p++ = '-'; | |
| 577 | 1494 n = -n; |
| 428 | 1495 } |
| 1496 | |
| 577 | 1497 if (n < 10) { DIGITS_1 (1); } |
| 1498 else if (n < 100) { DIGITS_2 (10); } | |
| 1499 else if (n < 1000) { DIGITS_3 (100); } | |
| 1500 else if (n < 10000) { DIGITS_4 (1000); } | |
| 1501 else if (n < 100000) { DIGITS_5 (10000); } | |
| 1502 else if (n < 1000000) { DIGITS_6 (100000); } | |
| 1503 else if (n < 10000000) { DIGITS_7 (1000000); } | |
| 1504 else if (n < 100000000) { DIGITS_8 (10000000); } | |
| 1505 else if (n < 1000000000) { DIGITS_9 (100000000); } | |
| 1506 #if SIZEOF_LONG == 4 | |
| 1507 /* ``if (1)'' serves only to preserve editor indentation. */ | |
| 1508 else if (1) { DIGITS_10 (1000000000); } | |
| 1509 #else /* SIZEOF_LONG != 4 */ | |
| 1510 else if (n < 10000000000L) { DIGITS_10 (1000000000L); } | |
| 1511 else if (n < 100000000000L) { DIGITS_11 (10000000000L); } | |
| 1512 else if (n < 1000000000000L) { DIGITS_12 (100000000000L); } | |
| 1513 else if (n < 10000000000000L) { DIGITS_13 (1000000000000L); } | |
| 1514 else if (n < 100000000000000L) { DIGITS_14 (10000000000000L); } | |
| 1515 else if (n < 1000000000000000L) { DIGITS_15 (100000000000000L); } | |
| 1516 else if (n < 10000000000000000L) { DIGITS_16 (1000000000000000L); } | |
| 1517 else if (n < 100000000000000000L) { DIGITS_17 (10000000000000000L); } | |
| 1518 else if (n < 1000000000000000000L) { DIGITS_18 (100000000000000000L); } | |
| 1519 else { DIGITS_19 (1000000000000000000L); } | |
| 1520 #endif /* SIZEOF_LONG != 4 */ | |
| 1521 | |
| 428 | 1522 *p = '\0'; |
| 1523 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ | |
| 1524 } | |
| 577 | 1525 |
| 1526 #undef ONE_DIGIT | |
| 1527 #undef ONE_DIGIT_ADVANCE | |
| 1528 | |
| 1529 #undef DIGITS_1 | |
| 1530 #undef DIGITS_2 | |
| 1531 #undef DIGITS_3 | |
| 1532 #undef DIGITS_4 | |
| 1533 #undef DIGITS_5 | |
| 1534 #undef DIGITS_6 | |
| 1535 #undef DIGITS_7 | |
| 1536 #undef DIGITS_8 | |
| 1537 #undef DIGITS_9 | |
| 1538 #undef DIGITS_10 | |
| 1539 #undef DIGITS_11 | |
| 1540 #undef DIGITS_12 | |
| 1541 #undef DIGITS_13 | |
| 1542 #undef DIGITS_14 | |
| 1543 #undef DIGITS_15 | |
| 1544 #undef DIGITS_16 | |
| 1545 #undef DIGITS_17 | |
| 1546 #undef DIGITS_18 | |
| 1547 #undef DIGITS_19 | |
| 428 | 1548 |
|
4329
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1549 void |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1550 ulong_to_bit_string (char *p, unsigned long number) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1551 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1552 int i, seen_high_order = 0;; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1553 |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1554 for (i = ((SIZEOF_LONG * 8) - 1); i >= 0; --i) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1555 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1556 if (number & (unsigned long)1 << i) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1557 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1558 seen_high_order = 1; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1559 *p++ = '1'; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1560 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1561 else |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1562 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1563 if (seen_high_order) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1564 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1565 *p++ = '0'; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1566 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1567 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1568 } |
|
5295
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1569 |
|
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1570 if (!seen_high_order) |
|
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1571 { |
|
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1572 *p++ = '0'; |
|
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1573 } |
|
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1574 |
|
4329
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1575 *p = '\0'; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1576 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1577 |
| 428 | 1578 static void |
| 442 | 1579 print_vector_internal (const char *start, const char *end, |
| 428 | 1580 Lisp_Object obj, |
| 1581 Lisp_Object printcharfun, int escapeflag) | |
| 1582 { | |
| 1583 /* This function can GC */ | |
| 1584 int i; | |
| 1585 int len = XVECTOR_LENGTH (obj); | |
| 1586 int last = len; | |
| 1587 struct gcpro gcpro1, gcpro2; | |
| 1588 GCPRO2 (obj, printcharfun); | |
| 1589 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1590 if (FIXNUMP (Vprint_length)) |
| 428 | 1591 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1592 int max = XFIXNUM (Vprint_length); |
| 428 | 1593 if (max < len) last = max; |
| 1594 } | |
| 1595 | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1596 write_cistring (printcharfun, start); |
| 428 | 1597 for (i = 0; i < last; i++) |
| 1598 { | |
| 1599 Lisp_Object elt = XVECTOR_DATA (obj)[i]; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1600 if (i != 0) write_ascstring (printcharfun, " "); |
| 428 | 1601 print_internal (elt, printcharfun, escapeflag); |
| 1602 } | |
| 1603 UNGCPRO; | |
| 1604 if (last != len) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1605 write_ascstring (printcharfun, " ..."); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1606 write_cistring (printcharfun, end); |
| 428 | 1607 } |
| 1608 | |
| 1609 void | |
| 1610 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1611 { | |
| 1612 /* This function can GC */ | |
| 1613 struct gcpro gcpro1, gcpro2; | |
| 1614 | |
| 1615 /* If print_readably is on, print (quote -foo-) as '-foo- | |
| 1616 (Yeah, this should really be what print-pretty does, but we | |
| 1617 don't have the rest of a pretty printer, and this actually | |
| 1618 has non-negligible impact on size/speed of .elc files.) | |
| 1619 */ | |
| 1620 if (print_readably && | |
| 1621 EQ (XCAR (obj), Qquote) && | |
| 1622 CONSP (XCDR (obj)) && | |
| 1623 NILP (XCDR (XCDR (obj)))) | |
| 1624 { | |
| 1625 obj = XCAR (XCDR (obj)); | |
| 1626 GCPRO2 (obj, printcharfun); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1627 write_ascstring (printcharfun, "\'"); |
| 428 | 1628 UNGCPRO; |
| 1629 print_internal (obj, printcharfun, escapeflag); | |
| 1630 return; | |
| 1631 } | |
| 1632 | |
| 1633 GCPRO2 (obj, printcharfun); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1634 write_ascstring (printcharfun, "("); |
| 428 | 1635 |
| 1636 { | |
| 1637 int len; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1638 int max = FIXNUMP (Vprint_length) ? XFIXNUM (Vprint_length) : INT_MAX; |
| 428 | 1639 Lisp_Object tortoise; |
| 1640 /* Use tortoise/hare to make sure circular lists don't infloop */ | |
| 1641 | |
| 1642 for (tortoise = obj, len = 0; | |
| 1643 CONSP (obj); | |
| 1644 obj = XCDR (obj), len++) | |
| 1645 { | |
| 1646 if (len > 0) | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1647 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1648 write_ascstring (printcharfun, " "); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1649 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1650 /* Note that print_cons is the only object method that does any |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1651 circularity checking itself, because a cons that is the cdr |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1652 of OBJ is not handed to print_internal in the ordinary course |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1653 of events. All the other possibly-repeated structures always |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1654 hand sub-objects to print_internal(). */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1655 if (print_circle && |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1656 FIXNUMP (Fgethash (obj, Vprint_number_table, Qnil))) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1657 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1658 write_ascstring (printcharfun, ". "); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1659 print_internal (obj, printcharfun, escapeflag); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1660 /* We have printed the list's tail, print_cons() is done. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1661 break; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1662 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1663 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1664 if (EQ (obj, tortoise)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1665 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1666 if (print_readably) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1667 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1668 printing_unreadable_object_fmt ("circular list"); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1669 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1670 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1671 write_ascstring (printcharfun, "... <circular list>"); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1672 break; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1673 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1674 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1675 if (len & 1) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1676 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1677 tortoise = XCDR (tortoise); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1678 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1679 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1680 if (len > max) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1681 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1682 write_ascstring (printcharfun, "..."); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1683 break; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1684 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1685 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1686 |
| 428 | 1687 print_internal (XCAR (obj), printcharfun, escapeflag); |
| 1688 } | |
| 1689 } | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1690 |
| 428 | 1691 if (!LISTP (obj)) |
| 1692 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1693 write_ascstring (printcharfun, " . "); |
| 428 | 1694 print_internal (obj, printcharfun, escapeflag); |
| 1695 } | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1696 |
| 428 | 1697 UNGCPRO; |
| 1698 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1699 write_ascstring (printcharfun, ")"); |
| 428 | 1700 return; |
| 1701 } | |
| 1702 | |
| 1703 void | |
| 1704 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1705 { | |
| 1706 print_vector_internal ("[", "]", obj, printcharfun, escapeflag); | |
| 1707 } | |
| 1708 | |
| 1709 void | |
| 1710 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1711 { | |
| 1712 /* We distinguish between Bytecounts and Charcounts, to make | |
| 1713 Vprint_string_length work correctly under Mule. */ | |
| 826 | 1714 Charcount size = string_char_length (obj); |
| 428 | 1715 Charcount max = size; |
| 793 | 1716 Bytecount bcmax = XSTRING_LENGTH (obj); |
| 428 | 1717 struct gcpro gcpro1, gcpro2; |
| 1718 GCPRO2 (obj, printcharfun); | |
| 1719 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1720 if (FIXNUMP (Vprint_string_length) && |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1721 XFIXNUM (Vprint_string_length) < max) |
| 428 | 1722 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1723 max = XFIXNUM (Vprint_string_length); |
| 793 | 1724 bcmax = string_index_char_to_byte (obj, max); |
| 428 | 1725 } |
| 1726 if (max < 0) | |
| 1727 { | |
| 1728 max = 0; | |
| 1729 bcmax = 0; | |
| 1730 } | |
| 1731 | |
| 1732 if (!escapeflag) | |
| 1733 { | |
| 1734 /* This deals with GC-relocation and Mule. */ | |
| 1735 output_string (printcharfun, 0, obj, 0, bcmax); | |
| 1736 if (max < size) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1737 write_ascstring (printcharfun, " ..."); |
| 428 | 1738 } |
| 1739 else | |
| 1740 { | |
| 1741 Bytecount i, last = 0; | |
| 1742 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1743 write_ascstring (printcharfun, "\""); |
| 428 | 1744 for (i = 0; i < bcmax; i++) |
| 1745 { | |
| 867 | 1746 Ibyte ch = string_byte (obj, i); |
| 428 | 1747 if (ch == '\"' || ch == '\\' |
| 1748 || (ch == '\n' && print_escape_newlines)) | |
| 1749 { | |
| 1750 if (i > last) | |
| 1751 { | |
| 1752 output_string (printcharfun, 0, obj, last, | |
| 1753 i - last); | |
| 1754 } | |
| 1755 if (ch == '\n') | |
| 1756 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1757 write_ascstring (printcharfun, "\\n"); |
| 428 | 1758 } |
| 1759 else | |
| 1760 { | |
| 867 | 1761 Ibyte temp[2]; |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1762 write_ascstring (printcharfun, "\\"); |
| 428 | 1763 /* This is correct for Mule because the |
| 1764 character is either \ or " */ | |
| 826 | 1765 temp[0] = string_byte (obj, i); |
| 1766 temp[1] = '\0'; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1767 write_istring (printcharfun, temp); |
| 428 | 1768 } |
| 1769 last = i + 1; | |
| 1770 } | |
| 1771 } | |
| 1772 if (bcmax > last) | |
| 1773 { | |
| 1774 output_string (printcharfun, 0, obj, last, | |
| 1775 bcmax - last); | |
| 1776 } | |
| 1777 if (max < size) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1778 write_ascstring (printcharfun, " ..."); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1779 write_ascstring (printcharfun, "\""); |
| 428 | 1780 } |
| 1781 UNGCPRO; | |
| 1782 } | |
| 1783 | |
| 4846 | 1784 DOESNT_RETURN |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1785 printing_unreadable_object_fmt (const Ascbyte *fmt, ...) |
| 4846 | 1786 { |
| 1787 Lisp_Object obj; | |
| 1788 va_list args; | |
| 1789 | |
| 1790 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1791 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 4846 | 1792 va_end (args); |
| 1793 | |
| 1794 /* Fsignal GC-protects its args */ | |
| 1795 signal_error (Qprinting_unreadable_object, 0, obj); | |
| 1796 } | |
| 1797 | |
| 1798 DOESNT_RETURN | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1799 printing_unreadable_lisp_object (Lisp_Object obj, const Ibyte *name) |
| 428 | 1800 { |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1801 struct lrecord_header *header = (struct lrecord_header *) XPNTR (obj); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1802 const struct lrecord_implementation *imp = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1803 XRECORD_LHEADER_IMPLEMENTATION (obj); |
| 428 | 1804 |
| 4846 | 1805 if (name) |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1806 printing_unreadable_object_fmt ("#<%s %s 0x%x>", imp->name, name, header->uid); |
| 4846 | 1807 else |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1808 printing_unreadable_object_fmt ("#<%s 0x%x>", imp->name, header->uid); |
| 4846 | 1809 } |
| 1810 | |
| 1811 void | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1812 external_object_printer (Lisp_Object obj, Lisp_Object printcharfun, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1813 int UNUSED (escapeflag)) |
| 4846 | 1814 { |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1815 struct lrecord_header *header = (struct lrecord_header *) XPNTR (obj); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1816 const struct lrecord_implementation *imp = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1817 XRECORD_LHEADER_IMPLEMENTATION (obj); |
| 4846 | 1818 |
| 1819 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1820 printing_unreadable_lisp_object (obj, 0); |
| 428 | 1821 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1822 write_fmt_string (printcharfun, "#<%s 0x%x>", imp->name, header->uid); |
| 428 | 1823 } |
| 1824 | |
| 1825 void | |
| 1826 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2286 | 1827 int UNUSED (escapeflag)) |
| 428 | 1828 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1829 if (print_readably) |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1830 printing_unreadable_object_fmt |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1831 ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%x>", |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1832 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, LISP_OBJECT_UID (obj)); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1833 |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1834 /* Internal objects shouldn't normally escape to the Lisp level; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1835 that's why we say "XEmacs bug?". This can happen, however, when |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1836 printing backtraces. */ |
| 800 | 1837 write_fmt_string (printcharfun, |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1838 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%x>", |
| 800 | 1839 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1840 LISP_OBJECT_UID (obj)); |
| 428 | 1841 } |
| 1842 | |
| 1204 | 1843 enum printing_badness |
| 1844 { | |
| 1845 BADNESS_INTEGER_OBJECT, | |
| 1846 BADNESS_POINTER_OBJECT, | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1847 BADNESS_POINTER_OBJECT_WITH_DATA, |
| 1204 | 1848 BADNESS_NO_TYPE |
| 1849 }; | |
| 1850 | |
| 1851 static void | |
| 1852 printing_major_badness (Lisp_Object printcharfun, | |
|
4528
726060ee587c
First draft of g++ 4.3 warning removal patch. Builds. *Needs ChangeLogs.*
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4522
diff
changeset
|
1853 const Ascbyte *badness_string, int type, void *val, |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1854 void *val2, enum printing_badness badness) |
| 1204 | 1855 { |
| 1856 Ibyte buf[666]; | |
| 1857 | |
| 1858 switch (badness) | |
| 1859 { | |
| 1860 case BADNESS_INTEGER_OBJECT: | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1861 qxesprintf (buf, "%s type %d object %ld", badness_string, type, |
| 1204 | 1862 (EMACS_INT) val); |
| 1863 break; | |
| 1864 | |
| 1865 case BADNESS_POINTER_OBJECT: | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1866 qxesprintf (buf, "%s type %d object %p", badness_string, type, val); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1867 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1868 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1869 case BADNESS_POINTER_OBJECT_WITH_DATA: |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1870 qxesprintf (buf, "%s type %d object %p data %p", badness_string, type, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1871 val, val2); |
| 1204 | 1872 break; |
| 1873 | |
| 1874 case BADNESS_NO_TYPE: | |
| 1875 qxesprintf (buf, "%s object %p", badness_string, val); | |
| 1876 break; | |
| 1877 } | |
| 1878 | |
| 1879 /* Don't abort or signal if called from debug_print() or already | |
| 1880 crashing */ | |
| 2367 | 1881 if (!inhibit_non_essential_conversion_operations) |
| 1204 | 1882 { |
| 1883 #ifdef ERROR_CHECK_TYPES | |
| 2500 | 1884 ABORT (); |
| 1204 | 1885 #else /* not ERROR_CHECK_TYPES */ |
| 1886 if (print_readably) | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1887 signal_ferror (Qinternal_error, "SERIOUS XEMACS BUG: printing %s; " |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1888 "save your buffers immediately and please report " |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1889 "this bug", buf); |
| 1204 | 1890 #endif /* not ERROR_CHECK_TYPES */ |
| 1891 } | |
| 1892 write_fmt_string (printcharfun, | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1893 "#<SERIOUS XEMACS BUG: %s Save your buffers immediately " |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1894 "and please report this bug>", buf); |
| 1204 | 1895 } |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1896 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1897 /* Not static only because of print_preprocess_cons. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1898 Elemcount print_preprocess_inchash_eq (Lisp_Object, Lisp_Object, Elemcount *); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1899 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1900 Elemcount |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1901 print_preprocess_inchash_eq (Lisp_Object obj, Lisp_Object table, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1902 Elemcount *seen_object_count) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1903 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1904 htentry *hte = inchash_eq (obj, table, 1); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1905 Elemcount extracted; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1906 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1907 /* If the hash table had to be resized, hte is NULL. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1908 if (hte == NULL) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1909 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1910 hte = find_htentry (obj, XHASH_TABLE (table)); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1911 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1912 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1913 extracted = XFIXNUM (hte->value); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1914 if (1 == extracted) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1915 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1916 *seen_object_count += 1; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1917 hte->value |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1918 = make_fixnum (1 | (*seen_object_count << PRINT_NUMBER_ORDINAL_SHIFT)); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1919 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1920 else if ((extracted & PRINT_NUMBER_SEEN_MASK) == PRINT_NUMBER_SEEN_MASK) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1921 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1922 /* Avoid the number overflowing the bit field. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1923 extracted = (extracted & ~PRINT_NUMBER_SEEN_MASK) | 2; |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1924 hte->value = make_fixnum (extracted); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1925 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1926 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1927 return extracted & PRINT_NUMBER_SEEN_MASK; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1928 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1929 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1930 /* Fill in Vprint_number_table according to the structure of OBJ. OBJ itself |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1931 and all its elements will be added to Vprint_number_table recursively if |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1932 its type has the print_preprocess method implemented. Objects with the |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1933 print_preprocess method implemented include cons, vector, compiled |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1934 function, hash table, char table, range table, and symbol. Symbol is an |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1935 exceptional type in that it is impossible to construct a recursive symbol |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1936 structure, but is here for the print-gensym feature. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1937 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1938 void |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1939 print_preprocess (Lisp_Object object, Lisp_Object print_number_table, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1940 Elemcount *seen_object_count) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1941 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1942 if (!LRECORDP (object) || !HAS_OBJECT_METH_P (object, print_preprocess)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1943 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1944 return; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1945 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1946 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1947 if (SYMBOLP (object) && IN_OBARRAY (object)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1948 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1949 /* Handle symbols specially. We do this here rather than in symbols.c |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1950 because we don't want to have all the other print_preprocess methods |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1951 worry about print_preprocess_inchash_eq. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1952 return; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1953 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1954 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1955 if (print_preprocess_inchash_eq (object, print_number_table, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1956 seen_object_count) > 1) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1957 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1958 return; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1959 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1960 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1961 OBJECT_METH (object, print_preprocess, (object, print_number_table, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1962 seen_object_count)); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1963 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1964 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1965 typedef struct { Lisp_Object key; Elemcount count; } preprocess_sort_t; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1966 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1967 static int |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1968 print_seen_once (Lisp_Object UNUSED (key), Lisp_Object value, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1969 void * UNUSED (extra_arg)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1970 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1971 return 1 == ((XFIXNUM (value) & PRINT_NUMBER_SEEN_MASK)); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1972 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1973 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1974 static int |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1975 print_nonsymbol_seen_once (Lisp_Object key, Lisp_Object value, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1976 void * UNUSED (extra_arg)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1977 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1978 /* print_continuous_numbering is used for symbols, so we don't delete them |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1979 from the print info hash table. It's less useful for other objects at |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1980 the moment, though. */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1981 return !SYMBOLP (key) && (1 == ((XFIXNUM (value) & PRINT_NUMBER_SEEN_MASK))); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1982 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1983 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1984 static int |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1985 print_sort_get_numbers (Lisp_Object key, Lisp_Object value, void *extra_arg) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1986 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1987 preprocess_sort_t **preprocess_sort_ptr = (preprocess_sort_t **) extra_arg; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1988 preprocess_sort_t *preprocess_sort = *preprocess_sort_ptr; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1989 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1990 *preprocess_sort_ptr += 1; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1991 preprocess_sort->key = key; |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1992 preprocess_sort->count = XFIXNUM (value); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1993 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1994 return 0; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1995 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1996 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1997 static int |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1998 print_sort_compare_ordinals (const void *object1, const void *object2) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
1999 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2000 Elemcount a = ((preprocess_sort_t *) object1)->count |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2001 & PRINT_NUMBER_ORDINAL_MASK; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2002 Elemcount b = ((preprocess_sort_t *) object2)->count |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2003 & PRINT_NUMBER_ORDINAL_MASK; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2004 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2005 return a - b; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2006 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2007 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2008 enum print_gensym_status |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2009 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2010 PRINT_GENSYM_DONE, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2011 PRINT_GENSYM_PRINT, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2012 PRINT_GENSYM_PRINT_AND_CLEANUP_TABLE, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2013 }; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2014 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2015 /* Check for any circular objects or repeated uninterned symbols. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2016 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2017 If OBJ is a repeated structure (or symbol) and it has been printed |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2018 already, print it now in the #%d# format, and return 1, to indicate |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2019 print_internal is done. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2020 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2021 If OBJ is a repeated structure and it has not yet been printed, print |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2022 #%d= before the object, mark it as printed, and return zero, to indicate |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2023 print_internal should continue as usual. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2024 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2025 If OBJ is not a repeated structure, do nothing, and return zero, to |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2026 indicate print_internal should continue as usual. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2027 static enum print_gensym_status |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2028 print_gensym_or_circle (Lisp_Object obj, Lisp_Object printcharfun) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2029 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2030 Lisp_Object seen = Fgethash (obj, Vprint_number_table, Qnil); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2031 if (NILP (seen)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2032 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2033 Elemcount old_print_number_index = print_number_index; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2034 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2035 print_preprocess (obj, Vprint_number_table, &print_number_index); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2036 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2037 if (old_print_number_index != print_number_index) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2038 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2039 Elemcount new_print_number_index, ii; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2040 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2041 /* We support up to 25 bits' worth of repeated objects, which is |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2042 33 million or so, far more than we support in, say, a |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2043 compiled-function constants vector. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2044 assert (print_number_index <= |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2045 (PRINT_NUMBER_ORDINAL_MASK >> PRINT_NUMBER_ORDINAL_SHIFT)); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2046 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2047 /* If any objects have been seen once and once only, remove them |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2048 from Vprint_number_table. This is a bit of an arbitrary |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2049 decision; we could keep them around for the sake of |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2050 print_continuous_numbering, but there's the reasonable worry |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2051 about Vprint_number_table getting awkwardly large. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2052 elisp_map_remhash (print_continuous_numbering ? |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2053 print_nonsymbol_seen_once : print_seen_once, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2054 Vprint_number_table, NULL); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2055 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2056 new_print_number_index |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2057 = XFIXNUM (Fhash_table_count (Vprint_number_table)); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2058 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2059 if (new_print_number_index != print_number_index |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2060 && new_print_number_index != old_print_number_index) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2061 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2062 preprocess_sort_t *preprocess_sort |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2063 = alloca_array (preprocess_sort_t, new_print_number_index); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2064 preprocess_sort_t *preprocess_sort_ptr = preprocess_sort; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2065 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2066 /* There are new objects in Vprint_number_table, but their |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2067 ordinal values don't necessarily represent the order they |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2068 were seen in, there will be gaps corresponding to the |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2069 non-symbols that were seen only once. Correct this. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2070 elisp_maphash_unsafe (print_sort_get_numbers, Vprint_number_table, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2071 &preprocess_sort_ptr); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2072 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2073 qsort (preprocess_sort, new_print_number_index, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2074 sizeof (preprocess_sort_t), print_sort_compare_ordinals); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2075 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2076 for (ii = old_print_number_index; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2077 ii < new_print_number_index; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2078 ii++) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2079 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2080 Fputhash (preprocess_sort[ii].key, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2081 make_fixnum ((preprocess_sort[ii].count |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2082 & ~PRINT_NUMBER_ORDINAL_MASK) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2083 | ((ii + 1) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2084 << PRINT_NUMBER_ORDINAL_SHIFT)), |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2085 Vprint_number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2086 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2087 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2088 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2089 print_number_index = new_print_number_index; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2090 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2091 /* The new objects may include OBJ; update SEEN to reflect |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2092 this. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2093 seen = Fgethash (obj, Vprint_number_table, Qnil); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2094 if (FIXNUMP (seen)) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2095 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2096 goto prefix_this; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2097 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2098 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2099 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2100 else |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2101 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2102 prefix_this: |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2103 if ((XFIXNUM (seen) & PRINT_NUMBER_SEEN_MASK) == 1 |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2104 && !(print_continuous_numbering && SYMBOLP (obj))) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2105 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2106 return PRINT_GENSYM_PRINT_AND_CLEANUP_TABLE; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2107 } |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2108 else if (XFIXNUM (seen) & PRINT_NUMBER_PRINTED_MASK) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2109 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2110 write_fmt_string (printcharfun, "#%d#", |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2111 (XFIXNUM (seen) & PRINT_NUMBER_ORDINAL_MASK) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2112 >> PRINT_NUMBER_ORDINAL_SHIFT); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2113 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2114 /* We're finished printing this object. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2115 return PRINT_GENSYM_DONE; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2116 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2117 else |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2118 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2119 write_fmt_string (printcharfun, "#%d=", |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2120 (XFIXNUM (seen) & PRINT_NUMBER_ORDINAL_MASK) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2121 >> PRINT_NUMBER_ORDINAL_SHIFT); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2122 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2123 /* We set PRINT_NUMBER_PRINTED_MASK immediately here, so the |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2124 object itself is written as #%d# when printing its contents. */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2125 Fputhash (obj, make_fixnum (XFIXNUM (seen) | PRINT_NUMBER_PRINTED_MASK), |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2126 Vprint_number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2127 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2128 /* This is the first time the object has been seen while |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2129 printing the recursive object; we still have to go ahead |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2130 and do the actual print. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2131 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2132 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2133 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2134 return PRINT_GENSYM_PRINT; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2135 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2136 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2137 Lisp_Object |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2138 nsubst_structures_descend (Lisp_Object new_, Lisp_Object old, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2139 Lisp_Object tree, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2140 Lisp_Object number_table, Boolint test_not_unboundp) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2141 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2142 Lisp_Object seen; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2143 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2144 if (!LRECORDP (tree) || !HAS_OBJECT_METH_P (tree, nsubst_structures_descend)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2145 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2146 return tree; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2147 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2148 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2149 seen = Fgethash (tree, number_table, Qnil); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2150 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2151 if (FIXNUMP (seen)) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2152 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2153 if (XFIXNUM (seen) & PRINT_NUMBER_PRINTED_MASK) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2154 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2155 return tree; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2156 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2157 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2158 Fputhash (tree, make_fixnum (XFIXNUM (seen) | PRINT_NUMBER_PRINTED_MASK), |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2159 number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2160 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2161 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2162 OBJECT_METH (tree, nsubst_structures_descend, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2163 (new_, old, tree, number_table, test_not_unboundp)); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2164 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2165 return tree; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2166 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2167 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2168 /* Descend TREE, replacing the Lisp object OLD each time it is encountered |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2169 with the Lisp object NEW_. TREE can be recursive or circular, and this is |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2170 handled correctly. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2171 Lisp_Object |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2172 nsubst_structures (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2173 check_test_func_t check_test, Boolint test_not_unboundp, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2174 Lisp_Object UNUSED (test), Lisp_Object UNUSED (key)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2175 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2176 Lisp_Object number_table, result; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2177 Elemcount ordinal = 0; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2178 struct gcpro gcpro1; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2179 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2180 if (check_test != check_eq_nokey || !LRECORDP (old)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2181 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2182 signal_error (Qunimplemented, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2183 ":descend-structures not yet finished, nsubst", |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2184 Qunbound); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2185 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2186 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2187 if (!LRECORDP (tree) || !HAS_OBJECT_METH_P (tree, nsubst_structures_descend)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2188 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2189 return tree; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2190 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2191 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2192 number_table = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, Qeq); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2193 GCPRO1 (number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2194 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2195 print_preprocess (tree, number_table, &ordinal); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2196 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2197 /* This function can GC by means of the hash table test functions, when |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2198 replacing hash table entries. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2199 result = nsubst_structures_descend (new_, old, tree, number_table, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2200 test_not_unboundp); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2201 Fclrhash (number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2202 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2203 RETURN_UNGCPRO (result); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2204 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2205 |
| 428 | 2206 void |
| 2207 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 2208 { | |
| 2209 /* This function can GC */ | |
| 2001 | 2210 int specdepth = 0; |
| 1204 | 2211 struct gcpro gcpro1, gcpro2; |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2212 Boolint cleanup_table = 0; |
| 428 | 2213 |
| 2214 QUIT; | |
| 2215 | |
| 771 | 2216 #ifdef NO_PRINT_DURING_GC |
| 428 | 2217 /* Emacs won't print while GCing, but an external debugger might */ |
| 2218 if (gc_in_progress) return; | |
| 771 | 2219 #endif |
| 2220 | |
| 1204 | 2221 /* Just to be safe ... */ |
| 2222 GCPRO2 (obj, printcharfun); | |
| 428 | 2223 |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2224 /* WARNING WARNING WARNING!!! Don't put anything here that might |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2225 dereference memory. Instead, put it down inside of |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2226 the case Lisp_Type_Record, after the appropriate checks to make sure |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2227 we're not dereferencing bad memory. The idea is that, ideally, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2228 calling debug_print() should *NEVER* make the program crash, even when |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2229 something very bad has happened. --ben */ |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2230 |
| 428 | 2231 #ifdef I18N3 |
| 2232 /* #### Both input and output streams should have a flag associated | |
| 2233 with them indicating whether output to that stream, or strings | |
| 2234 read from the stream, get translated using Fgettext(). Such a | |
| 2235 stream is called a "translating stream". For the minibuffer and | |
| 2236 external-debugging-output this is always true on output, and | |
| 2237 with-output-to-temp-buffer sets the flag to true for the buffer | |
| 2238 it creates. This flag should also be user-settable. Perhaps it | |
| 2239 should be split up into two flags, one for input and one for | |
| 2240 output. */ | |
| 2241 #endif | |
| 2242 | |
| 2243 being_printed[print_depth] = obj; | |
| 2244 | |
| 1957 | 2245 /* Avoid calling internal_bind_int, which conses, when called from |
| 2246 debug_prin1. In that case, we have bound print_depth to 0 anyway. */ | |
| 2367 | 2247 if (!inhibit_non_essential_conversion_operations) |
| 1957 | 2248 { |
| 2249 specdepth = internal_bind_int (&print_depth, print_depth + 1); | |
| 2250 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2251 if (print_depth > PRINT_CIRCLE_LIMIT) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2252 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2253 signal_error (Qstack_overflow, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2254 "Apparently circular structure being printed", |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2255 Qunbound); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2256 } |
| 1957 | 2257 } |
| 428 | 2258 |
| 2259 switch (XTYPE (obj)) | |
| 2260 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2261 case Lisp_Type_Fixnum_Even: |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2262 case Lisp_Type_Fixnum_Odd: |
| 428 | 2263 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2264 Ascbyte buf[DECIMAL_PRINT_SIZE (EMACS_INT)]; |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2265 long_to_string (buf, XFIXNUM (obj)); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2266 write_ascstring (printcharfun, buf); |
| 428 | 2267 break; |
| 2268 } | |
| 2269 | |
| 2270 case Lisp_Type_Char: | |
| 2271 { | |
| 2272 /* God intended that this be #\..., you know. */ | |
| 2273 char buf[16]; | |
| 867 | 2274 Ichar ch = XCHAR (obj); |
| 428 | 2275 char *p = buf; |
| 2276 *p++ = '?'; | |
| 434 | 2277 if (ch < 32) |
| 2278 { | |
| 2279 *p++ = '\\'; | |
| 2280 switch (ch) | |
| 2281 { | |
| 2282 case '\t': *p++ = 't'; break; | |
| 2283 case '\n': *p++ = 'n'; break; | |
| 2284 case '\r': *p++ = 'r'; break; | |
| 2285 default: | |
| 2286 *p++ = '^'; | |
| 2287 *p++ = ch + 64; | |
| 2288 if ((ch + 64) == '\\') | |
| 2289 *p++ = '\\'; | |
| 2290 break; | |
| 2291 } | |
| 2292 } | |
| 2293 else if (ch < 127) | |
| 428 | 2294 { |
| 434 | 2295 /* syntactically special characters should be escaped. */ |
| 2296 switch (ch) | |
| 2297 { | |
| 2298 case ' ': | |
| 2299 case '"': | |
| 2300 case '#': | |
| 2301 case '\'': | |
| 2302 case '(': | |
| 2303 case ')': | |
| 2304 case ',': | |
| 2305 case '.': | |
| 2306 case ';': | |
| 2307 case '?': | |
| 2308 case '[': | |
| 2309 case '\\': | |
| 2310 case ']': | |
| 2311 case '`': | |
| 2312 *p++ = '\\'; | |
| 2313 } | |
| 2314 *p++ = ch; | |
| 428 | 2315 } |
| 2316 else if (ch == 127) | |
| 434 | 2317 { |
| 2318 *p++ = '\\', *p++ = '^', *p++ = '?'; | |
| 2319 } | |
| 2320 else if (ch < 160) | |
| 428 | 2321 { |
| 2322 *p++ = '\\', *p++ = '^'; | |
| 867 | 2323 p += set_itext_ichar ((Ibyte *) p, ch + 64); |
| 428 | 2324 } |
| 2325 else | |
| 434 | 2326 { |
| 867 | 2327 p += set_itext_ichar ((Ibyte *) p, ch); |
| 434 | 2328 } |
| 440 | 2329 |
| 867 | 2330 output_string (printcharfun, (Ibyte *) buf, Qnil, 0, p - buf); |
| 434 | 2331 |
| 428 | 2332 break; |
| 2333 } | |
| 2334 | |
| 2335 case Lisp_Type_Record: | |
| 2336 { | |
| 2337 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 1204 | 2338 |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2339 /* Try to check for various sorts of bogus pointers or bad memory |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2340 if we're in a situation where it may be likely -- i.e. called |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2341 from debug_print() or we're already crashing. In such cases, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2342 (further) crashing is counterproductive. |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2343 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2344 We don't normally do these because they may be expensive or |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2345 weird (e.g. under Unix we typically have to set a SIGSEGV |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2346 handler and try to trigger a seg fault). */ |
| 428 | 2347 |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2348 if (!lheader) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2349 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2350 /* i.e. EQ Qnull_pointer */ |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2351 printing_major_badness (printcharfun, "NULL POINTER LRECORD", 0, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2352 0, 0, BADNESS_NO_TYPE); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2353 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2354 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2355 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2356 /* First check to see if the lrecord header itself is garbage. */ |
| 2367 | 2357 if (inhibit_non_essential_conversion_operations && |
| 1204 | 2358 !debug_can_access_memory (lheader, sizeof (*lheader))) |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2359 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2360 printing_major_badness (printcharfun, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2361 "BAD MEMORY in LRECORD HEADER", 0, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2362 lheader, 0, BADNESS_NO_TYPE); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2363 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2364 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2365 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2366 /* Check to see if the lrecord type is garbage. */ |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2367 #ifndef NEW_GC |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2368 if (lheader->type == lrecord_type_free) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2369 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2370 printing_major_badness (printcharfun, "FREED LRECORD", 0, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2371 lheader, 0, BADNESS_NO_TYPE); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2372 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2373 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2374 if (lheader->type == lrecord_type_undefined) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2375 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2376 printing_major_badness (printcharfun, "LRECORD_TYPE_UNDEFINED", 0, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2377 lheader, 0, BADNESS_NO_TYPE); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2378 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2379 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2380 #endif /* not NEW_GC */ |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2381 if ((int) (lheader->type) >= lrecord_type_count) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2382 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2383 printing_major_badness (printcharfun, "ILLEGAL LRECORD TYPE", |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2384 (int) (lheader->type), |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2385 lheader, 0, BADNESS_POINTER_OBJECT); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2386 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2387 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2388 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2389 /* Check to see if the lrecord implementation is missing or garbage. */ |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2390 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2391 const struct lrecord_implementation *imp = |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2392 LHEADER_IMPLEMENTATION (lheader); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2393 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2394 if (!imp) |
| 1204 | 2395 { |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2396 printing_major_badness |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2397 (printcharfun, "NO IMPLEMENTATION FOR LRECORD TYPE", |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2398 (int) (lheader->type), |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2399 lheader, 0, BADNESS_POINTER_OBJECT); |
| 1204 | 2400 break; |
| 2401 } | |
| 2402 | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2403 if (inhibit_non_essential_conversion_operations) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2404 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2405 if (!debug_can_access_memory (imp, sizeof (*imp))) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2406 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2407 printing_major_badness |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2408 (printcharfun, "BAD MEMORY IN LRECORD IMPLEMENTATION", |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2409 (int) (lheader->type), |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2410 lheader, 0, BADNESS_POINTER_OBJECT); |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2411 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2412 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2413 } |
| 428 | 2414 |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2415 /* Check to see if any of the memory of the lrecord is inaccessible. |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2416 Note that we already checked above to see if the first part of |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2417 the lrecord (the header) is inaccessible, which will catch most |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2418 cases of a totally bad pointer. */ |
| 1204 | 2419 |
| 2367 | 2420 if (inhibit_non_essential_conversion_operations) |
| 1204 | 2421 { |
| 2422 if (!debug_can_access_memory | |
| 2423 (lheader, detagged_lisp_object_size (lheader))) | |
| 2424 { | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2425 printing_major_badness (printcharfun, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2426 "BAD MEMORY IN LRECORD", |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2427 (int) (lheader->type), |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2428 lheader, 0, BADNESS_POINTER_OBJECT); |
| 1204 | 2429 break; |
| 2430 } | |
| 2431 | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2432 /* For strings, also check the data of the string itself. */ |
| 1204 | 2433 if (STRINGP (obj)) |
| 2434 { | |
| 3092 | 2435 #ifdef NEW_GC |
| 2436 if (!debug_can_access_memory (XSTRING_DATA (obj), | |
| 2437 XSTRING_LENGTH (obj))) | |
| 2438 { | |
| 2439 write_fmt_string | |
| 2440 (printcharfun, | |
| 2441 "#<EMACS BUG: %p (BAD STRING DATA %p)>", | |
| 2442 lheader, XSTRING_DATA (obj)); | |
| 2443 break; | |
| 2444 } | |
| 2445 #else /* not NEW_GC */ | |
| 1204 | 2446 Lisp_String *l = (Lisp_String *) lheader; |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5189
diff
changeset
|
2447 if (l->size_ && !debug_can_access_memory (l->data_, l->size_)) |
| 1204 | 2448 { |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2449 printing_major_badness (printcharfun, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2450 "BAD STRING DATA", (int) (lheader->type), |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2451 lheader, l->data_, |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2452 BADNESS_POINTER_OBJECT_WITH_DATA); |
| 1204 | 2453 break; |
| 2454 } | |
| 3092 | 2455 #endif /* not NEW_GC */ |
| 1204 | 2456 } |
| 2457 } | |
| 2458 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2459 if (LRECORDP (obj) && |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2460 ((print_circle && HAS_OBJECT_METH_P (obj, print_preprocess)) || |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2461 (print_gensym && SYMBOLP (obj) && !IN_OBARRAY (obj)))) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2462 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2463 enum print_gensym_status status |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2464 = print_gensym_or_circle (obj, printcharfun); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2465 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2466 cleanup_table = (PRINT_GENSYM_PRINT_AND_CLEANUP_TABLE == status); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2467 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2468 if (PRINT_GENSYM_DONE == status) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2469 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2470 break; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2471 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2472 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2473 else if (!print_circle && |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2474 /* Could this structure be recursive? */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2475 LRECORDP (obj) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2476 && HAS_OBJECT_METH_P (obj, nsubst_structures_descend)) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2477 { |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2478 int i; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2479 for (i = 0; i < print_depth - 1; i++) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2480 if (EQ (obj, being_printed[i])) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2481 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2482 Ascbyte buf[DECIMAL_PRINT_SIZE (long) + 1]; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2483 *buf = '#'; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2484 long_to_string (buf + 1, i); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2485 write_ascstring (printcharfun, buf); |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2486 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2487 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2488 if (i < print_depth - 1) /* Did we print something? */ |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2489 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2490 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2491 |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2492 if (CONSP (obj) || VECTORP (obj)) |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2493 { |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2494 /* If deeper than spec'd depth, print placeholder. */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2495 if (FIXNUMP (Vprint_level) |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2496 && print_depth > XFIXNUM (Vprint_level)) |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2497 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2498 write_ascstring (printcharfun, "..."); |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2499 break; |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2500 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2501 } |
|
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2502 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2503 /* Either use a custom-written printer, or use |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2504 internal_object_printer or external_object_printer, depending on |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2505 whether the object is internal (not visible at Lisp level) or |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2506 external. */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2507 assert (LHEADER_IMPLEMENTATION (lheader)->printer); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2508 ((LHEADER_IMPLEMENTATION (lheader)->printer) |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2509 (obj, printcharfun, escapeflag)); |
| 428 | 2510 break; |
| 2511 } | |
| 2512 | |
| 2513 default: | |
| 2514 { | |
| 2515 /* We're in trouble if this happens! */ | |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2516 printing_major_badness (printcharfun, "ILLEGAL LISP OBJECT TAG TYPE", |
| 5013 | 2517 XTYPE (obj), STORE_LISP_IN_VOID (obj), 0, |
|
4847
05c519de7353
be more careful when printing to check for bad objects
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2518 BADNESS_INTEGER_OBJECT); |
| 428 | 2519 break; |
| 2520 } | |
| 2521 } | |
| 2522 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2523 if (cleanup_table) |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2524 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2525 /* If any objects have been seen once and once only, remove them from |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2526 Vprint_number_table. This is a bit of an arbitrary decision; we |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2527 could keep them around for the sake of print_continuous_numbering, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2528 but there's the reasonable worry about Vprint_number_table getting |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2529 awkwardly large. */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2530 elisp_map_remhash (print_continuous_numbering ? |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2531 print_nonsymbol_seen_once : print_seen_once, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2532 Vprint_number_table, NULL); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2533 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2534 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2535 |
| 2367 | 2536 if (!inhibit_non_essential_conversion_operations) |
| 1957 | 2537 unbind_to (specdepth); |
| 1204 | 2538 UNGCPRO; |
| 428 | 2539 } |
| 2540 | |
| 2541 void | |
| 2286 | 2542 print_float (Lisp_Object obj, Lisp_Object printcharfun, |
| 2543 int UNUSED (escapeflag)) | |
| 428 | 2544 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2545 Ascbyte pigbuf[350]; /* see comments in float_to_string */ |
| 428 | 2546 |
| 2547 float_to_string (pigbuf, XFLOAT_DATA (obj)); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2548 write_ascstring (printcharfun, pigbuf); |
| 428 | 2549 } |
| 2550 | |
| 2551 void | |
| 2552 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 2553 { | |
| 2554 /* This function can GC */ | |
| 793 | 2555 Lisp_Object name = symbol_name (XSYMBOL (obj)); |
| 2556 Bytecount size = XSTRING_LENGTH (name); | |
| 428 | 2557 struct gcpro gcpro1, gcpro2; |
| 2558 | |
| 2559 if (!escapeflag) | |
| 2560 { | |
| 2561 /* This deals with GC-relocation */ | |
| 793 | 2562 output_string (printcharfun, 0, name, 0, size); |
| 428 | 2563 return; |
| 2564 } | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
2565 |
| 428 | 2566 GCPRO2 (obj, printcharfun); |
| 2567 | |
|
5677
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2568 if (print_gensym && !IN_OBARRAY (obj)) |
| 428 | 2569 { |
|
5677
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2570 write_ascstring (printcharfun, "#:"); |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2571 } |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2572 else if (0 == size) |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2573 { |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2574 /* Compatible with GNU, but not with Common Lisp, where the syntax for |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2575 this symbol is ||. */ |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2576 write_ascstring (printcharfun, "##"); |
| 428 | 2577 } |
| 2578 | |
| 2579 /* Does it look like an integer or a float? */ | |
| 2580 { | |
| 867 | 2581 Ibyte *data = XSTRING_DATA (name); |
| 428 | 2582 Bytecount confusing = 0; |
| 2583 | |
| 2584 if (size == 0) | |
| 2585 goto not_yet_confused; /* Really confusing */ | |
| 2586 else if (isdigit (data[0])) | |
| 2587 confusing = 0; | |
| 2588 else if (size == 1) | |
| 2589 goto not_yet_confused; | |
| 2590 else if (data[0] == '-' || data[0] == '+') | |
| 2591 confusing = 1; | |
| 2592 else | |
| 2593 goto not_yet_confused; | |
| 2594 | |
| 2595 for (; confusing < size; confusing++) | |
| 2596 { | |
|
5243
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2597 if (!isdigit (data[confusing]) && '/' != data[confusing]) |
| 428 | 2598 { |
| 2599 confusing = 0; | |
| 2600 break; | |
| 2601 } | |
| 2602 } | |
| 2603 not_yet_confused: | |
| 2604 | |
| 2605 if (!confusing) | |
| 2606 /* #### Ugh, this is needlessly complex and slow for what we | |
| 2607 need here. It might be a good idea to copy equivalent code | |
| 2608 from FSF. --hniksic */ | |
|
5243
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2609 confusing = isfloat_string ((char *) data) |
|
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2610 || isratio_string ((char *) data); |
| 428 | 2611 if (confusing) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2612 write_ascstring (printcharfun, "\\"); |
| 428 | 2613 } |
| 2614 | |
| 2615 { | |
| 2616 Bytecount i; | |
| 2617 Bytecount last = 0; | |
| 2618 | |
| 2619 for (i = 0; i < size; i++) | |
| 2620 { | |
| 826 | 2621 switch (string_byte (name, i)) |
| 428 | 2622 { |
| 2623 case 0: case 1: case 2: case 3: | |
| 2624 case 4: case 5: case 6: case 7: | |
| 2625 case 8: case 9: case 10: case 11: | |
| 2626 case 12: case 13: case 14: case 15: | |
| 2627 case 16: case 17: case 18: case 19: | |
| 2628 case 20: case 21: case 22: case 23: | |
| 2629 case 24: case 25: case 26: case 27: | |
| 2630 case 28: case 29: case 30: case 31: | |
| 2631 case ' ': case '\"': case '\\': case '\'': | |
| 2632 case ';': case '#' : case '(' : case ')': | |
| 2633 case ',': case '.' : case '`' : | |
| 2634 case '[': case ']' : case '?' : | |
| 2635 if (i > last) | |
| 793 | 2636 output_string (printcharfun, 0, name, last, i - last); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2637 write_ascstring (printcharfun, "\\"); |
| 428 | 2638 last = i; |
| 2639 } | |
| 2640 } | |
| 793 | 2641 output_string (printcharfun, 0, name, last, size - last); |
| 428 | 2642 } |
| 2643 UNGCPRO; | |
| 2644 } | |
| 2645 | |
| 2646 | |
| 442 | 2647 /* Useful on systems or in places where writing to stdout is unavailable or |
| 2648 not working. */ | |
| 428 | 2649 |
| 2650 static int alternate_do_pointer; | |
| 1957 | 2651 static int alternate_do_size; |
| 2652 static char *alternate_do_string; | |
| 428 | 2653 |
| 2654 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* | |
| 2655 Append CHARACTER to the array `alternate_do_string'. | |
| 2656 This can be used in place of `external-debugging-output' as a function | |
| 2657 to be passed to `print'. Before calling `print', set `alternate_do_pointer' | |
| 2658 to 0. | |
| 2659 */ | |
| 2660 (character)) | |
| 2661 { | |
| 867 | 2662 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 2663 Bytecount len; |
| 2664 | |
| 2665 CHECK_CHAR_COERCE_INT (character); | |
| 867 | 2666 len = set_itext_ichar (str, XCHAR (character)); |
| 771 | 2667 write_string_to_alternate_debugging_output (str, len); |
| 2668 | |
| 2669 return character; | |
| 2670 } | |
| 2671 | |
| 2672 static void | |
| 1346 | 2673 write_string_to_alternate_debugging_output (const Ibyte *str, Bytecount len) |
| 771 | 2674 { |
| 2675 int extlen; | |
| 2676 const Extbyte *extptr; | |
| 2677 #if 0 /* We want to see the internal representation, don't we? */ | |
| 2367 | 2678 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 2679 TO_EXTERNAL_FORMAT (DATA, (str, len), |
| 2680 ALLOCA, (extptr, extlen), | |
| 2681 Qterminal); | |
| 2682 else | |
| 2683 #endif /* 0 */ | |
| 2684 { | |
| 2685 extlen = len; | |
| 2686 extptr = (Extbyte *) str; | |
| 2687 } | |
| 1957 | 2688 |
| 2689 /* If not yet initialized, just skip it. */ | |
| 2690 if (alternate_do_string == NULL) | |
| 2691 return; | |
| 2692 | |
| 2693 if (alternate_do_pointer + extlen >= alternate_do_size) | |
| 2694 { | |
| 2695 alternate_do_size = | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2696 max (alternate_do_size * 2, alternate_do_pointer + extlen + 1); |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2697 XREALLOC_ARRAY (alternate_do_string, CIbyte, alternate_do_size); |
| 1957 | 2698 } |
| 428 | 2699 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); |
| 2700 alternate_do_pointer += extlen; | |
| 2701 alternate_do_string[alternate_do_pointer] = 0; | |
| 2702 } | |
| 2703 | |
| 1346 | 2704 |
| 2705 DEFUN ("set-device-clear-left-side", Fset_device_clear_left_side, 2, 2, 0, /* | |
| 2706 Set whether to output a newline before the next output to a stream device. | |
| 2707 This will happen only if the most recently-outputted character was not | |
| 2708 a newline -- i.e. it will make sure the left side is "clear" of text. | |
| 2709 */ | |
| 2710 (device, value)) | |
| 2711 { | |
| 2712 if (!NILP (device)) | |
| 2713 CHECK_LIVE_DEVICE (device); | |
| 2714 if (NILP (device) || DEVICE_STREAM_P (XDEVICE (device))) | |
| 2715 /* #### This should be per-device */ | |
| 2716 stdout_clear_before_next_output = !NILP (value); | |
| 2717 return Qnil; | |
| 2718 } | |
| 2719 | |
| 2720 DEFUN ("device-left-side-clear-p", Fdevice_left_side_clear_p, 0, 1, 0, /* | |
| 2721 For stream devices, true if the most recent-outputted character was a newline. | |
| 2722 */ | |
| 2723 (device)) | |
| 2724 { | |
| 2725 if (!NILP (device)) | |
| 2726 CHECK_LIVE_DEVICE (device); | |
| 2727 if (NILP (device) || DEVICE_STREAM_P (XDEVICE (device))) | |
| 2728 /* #### This should be per-device */ | |
| 2729 return stdout_needs_newline ? Qt : Qnil; | |
| 2730 return Qnil; | |
| 2731 } | |
| 2732 | |
| 428 | 2733 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /* |
| 2734 Write CHAR-OR-STRING to stderr or stdout. | |
| 2735 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write | |
| 2736 to stderr. You can use this function to write directly to the terminal. | |
| 2737 This function can be used as the STREAM argument of Fprint() or the like. | |
| 2738 | |
| 442 | 2739 Under MS Windows, this writes output to the console window (which is |
| 2740 created, if necessary), unless XEmacs is being run noninteractively | |
| 2741 \(i.e. using the `-batch' argument). | |
| 2742 | |
| 428 | 2743 If you have opened a termscript file (using `open-termscript'), then |
| 2744 the output also will be logged to this file. | |
| 2745 */ | |
| 2746 (char_or_string, stdout_p, device)) | |
| 2747 { | |
| 2748 FILE *file = 0; | |
| 2749 struct console *con = 0; | |
| 2750 | |
| 2751 if (NILP (device)) | |
| 2752 { | |
| 2753 if (!NILP (stdout_p)) | |
| 2754 file = stdout; | |
| 2755 else | |
| 2756 file = stderr; | |
| 2757 } | |
| 2758 else | |
| 2759 { | |
| 2760 CHECK_LIVE_DEVICE (device); | |
| 2761 if (!DEVICE_TTY_P (XDEVICE (device)) && | |
| 2762 !DEVICE_STREAM_P (XDEVICE (device))) | |
| 563 | 2763 wtaerror ("Must be tty or stream device", device); |
| 428 | 2764 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device))); |
| 2765 if (DEVICE_TTY_P (XDEVICE (device))) | |
| 2766 file = 0; | |
| 2767 else if (!NILP (stdout_p)) | |
| 2768 file = CONSOLE_STREAM_DATA (con)->out; | |
| 2769 else | |
| 2770 file = CONSOLE_STREAM_DATA (con)->err; | |
| 2771 } | |
| 2772 | |
| 2773 if (STRINGP (char_or_string)) | |
| 2774 write_string_to_stdio_stream (file, con, | |
| 2775 XSTRING_DATA (char_or_string), | |
| 771 | 2776 XSTRING_LENGTH (char_or_string), |
| 2777 print_unbuffered); | |
| 428 | 2778 else |
| 2779 { | |
| 867 | 2780 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 2781 Bytecount len; |
| 2782 | |
| 2783 CHECK_CHAR_COERCE_INT (char_or_string); | |
| 867 | 2784 len = set_itext_ichar (str, XCHAR (char_or_string)); |
| 771 | 2785 write_string_to_stdio_stream (file, con, str, len, print_unbuffered); |
| 428 | 2786 } |
| 2787 | |
| 2788 return char_or_string; | |
| 2789 } | |
| 2790 | |
| 2791 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /* | |
| 444 | 2792 Start writing all terminal output to FILENAME as well as the terminal. |
| 2793 FILENAME = nil means just close any termscript file currently open. | |
| 428 | 2794 */ |
| 444 | 2795 (filename)) |
| 428 | 2796 { |
| 2797 /* This function can GC */ | |
| 2798 if (termscript != 0) | |
| 2799 { | |
| 771 | 2800 retry_fclose (termscript); |
| 444 | 2801 termscript = 0; |
| 2802 } | |
| 2803 | |
| 2804 if (! NILP (filename)) | |
| 2805 { | |
| 2806 filename = Fexpand_file_name (filename, Qnil); | |
| 771 | 2807 termscript = qxe_fopen (XSTRING_DATA (filename), "w"); |
| 428 | 2808 if (termscript == NULL) |
| 563 | 2809 report_file_error ("Opening termscript", filename); |
| 428 | 2810 } |
| 2811 return Qnil; | |
| 2812 } | |
| 2813 | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2814 static Lisp_Object |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2815 restore_inhibit_non_essential_conversion_operations (Lisp_Object obj) |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2816 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2817 inhibit_non_essential_conversion_operations = XFIXNUM (obj); |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2818 return Qnil; |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2819 } |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2820 |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2821 /* Bind the value of inhibit_non_essential_conversion_operations to 1 |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2822 in a way that involves no consing. */ |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2823 static int |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2824 begin_inhibit_non_essential_conversion_operations (void) |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2825 { |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2826 int depth = |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2827 record_unwind_protect |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2828 (restore_inhibit_non_essential_conversion_operations, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2829 make_fixnum (inhibit_non_essential_conversion_operations)); |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2830 inhibit_non_essential_conversion_operations = 1; |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2831 return depth; |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2832 } |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2833 |
| 440 | 2834 static int debug_print_length = 50; |
| 2835 static int debug_print_level = 15; | |
| 2836 static int debug_print_readably = -1; | |
| 428 | 2837 |
| 1957 | 2838 /* Restore values temporarily bound by debug_prin1. We use this approach to |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2839 avoid consing in debug_prin1. That is verboten, since debug_print can be |
| 1957 | 2840 called by cons debugging code. */ |
| 2841 static Lisp_Object | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2842 debug_print_exit (Lisp_Object val) |
| 1957 | 2843 { |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2844 struct debug_bindings *bindings = |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2845 (struct debug_bindings *) GET_VOID_FROM_LISP (val); |
| 2367 | 2846 inhibit_non_essential_conversion_operations = |
| 2847 bindings->inhibit_non_essential_conversion_operations; | |
| 1957 | 2848 print_depth = bindings->print_depth; |
| 2849 print_readably = bindings->print_readably; | |
| 2850 print_unbuffered = bindings->print_unbuffered; | |
|
5796
acf1c26e3019
Bind print-circle when printing backtraces.
Jerry James <james@xemacs.org>
parents:
5776
diff
changeset
|
2851 print_circle = bindings->print_circle; |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
2852 in_debug_print = bindings->in_debug_print; |
| 1957 | 2853 gc_currently_forbidden = bindings->gc_currently_forbidden; |
| 2854 Vprint_length = bindings->Vprint_length; | |
| 2855 Vprint_level = bindings->Vprint_level; | |
| 2856 Vinhibit_quit = bindings->Vinhibit_quit; | |
| 2857 return Qnil; | |
| 2858 } | |
| 2859 | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2860 /* Save values and bind them to new values suitable for debug output. We |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2861 try very hard to avoid any Lisp allocation (i.e. consing) during the |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2862 operation of debug printing, since we might be calling it from inside GC |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2863 or other sensitive places. This means we have to be a bit careful with |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2864 record_unwind_protect to not create any temporary Lisp objects. */ |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2865 |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2866 static int |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2867 debug_print_enter (struct debug_bindings *bindings) |
| 428 | 2868 { |
| 853 | 2869 /* by doing this, we trick various things that are non-essential |
| 2870 but might cause crashes into not getting executed. */ | |
| 1957 | 2871 int specdepth; |
| 853 | 2872 |
| 2367 | 2873 bindings->inhibit_non_essential_conversion_operations = |
| 2874 inhibit_non_essential_conversion_operations; | |
| 1957 | 2875 bindings->print_depth = print_depth; |
| 2876 bindings->print_readably = print_readably; | |
| 2877 bindings->print_unbuffered = print_unbuffered; | |
|
5796
acf1c26e3019
Bind print-circle when printing backtraces.
Jerry James <james@xemacs.org>
parents:
5776
diff
changeset
|
2878 bindings->print_circle = print_circle; |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
2879 bindings->in_debug_print = in_debug_print; |
| 1957 | 2880 bindings->gc_currently_forbidden = gc_currently_forbidden; |
| 2881 bindings->Vprint_length = Vprint_length; | |
| 2882 bindings->Vprint_level = Vprint_level; | |
| 2883 bindings->Vinhibit_quit = Vinhibit_quit; | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2884 specdepth = record_unwind_protect (debug_print_exit, |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2885 STORE_VOID_IN_LISP (bindings)); |
| 1957 | 2886 |
| 2367 | 2887 inhibit_non_essential_conversion_operations = 1; |
| 1957 | 2888 print_depth = 0; |
| 2889 print_readably = debug_print_readably != -1 ? debug_print_readably : 0; | |
| 2890 print_unbuffered++; | |
|
5796
acf1c26e3019
Bind print-circle when printing backtraces.
Jerry James <james@xemacs.org>
parents:
5776
diff
changeset
|
2891 print_circle = 1; |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
2892 in_debug_print = 1; |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4847
diff
changeset
|
2893 gc_currently_forbidden = 1; |
| 428 | 2894 if (debug_print_length > 0) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2895 Vprint_length = make_fixnum (debug_print_length); |
| 428 | 2896 if (debug_print_level > 0) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2897 Vprint_level = make_fixnum (debug_print_level); |
| 1957 | 2898 Vinhibit_quit = Qt; |
| 1346 | 2899 |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2900 return specdepth; |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2901 } |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2902 |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2903 /* Print an object, `prin1'-style, to various possible debugging outputs. |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2904 Make sure it's completely unbuffered so that, in the event of a crash |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2905 somewhere, we see as much as possible that happened before it. |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2906 */ |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2907 static void |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2908 debug_prin1 (Lisp_Object debug_print_obj, int flags) |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2909 { |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2910 /* This function cannot GC, since GC is forbidden */ |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2911 struct debug_bindings bindings; |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2912 int specdepth = debug_print_enter (&bindings); |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2913 |
| 1346 | 2914 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR)) |
| 2915 print_internal (debug_print_obj, Qexternal_debugging_output, 1); | |
| 2916 if (flags & EXT_PRINT_ALTERNATE) | |
| 2917 print_internal (debug_print_obj, Qalternate_debugging_output, 1); | |
| 442 | 2918 #ifdef WIN32_NATIVE |
| 1346 | 2919 if (flags & EXT_PRINT_MSWINDOWS) |
| 2920 { | |
| 2921 /* Write out to the debugger, as well */ | |
| 2922 print_internal (debug_print_obj, Qmswindows_debugging_output, 1); | |
| 2923 } | |
| 442 | 2924 #endif |
| 440 | 2925 |
| 802 | 2926 unbind_to (specdepth); |
| 428 | 2927 } |
| 2928 | |
| 2929 void | |
| 1204 | 2930 debug_p4 (Lisp_Object obj) |
| 2931 { | |
| 2932 if (STRINGP (obj)) | |
| 2933 debug_out ("\"%s\"", XSTRING_DATA (obj)); | |
| 2934 else if (CONSP (obj)) | |
| 2935 { | |
| 2936 int first = 1; | |
| 2937 do { | |
| 2938 debug_out (first ? "(" : " "); | |
| 2939 first = 0; | |
| 2940 debug_p4 (XCAR (obj)); | |
| 2941 obj = XCDR (obj); | |
| 2942 } while (CONSP (obj)); | |
| 2943 if (NILP (obj)) | |
| 2944 debug_out (")"); | |
| 2945 else | |
| 2946 { | |
| 2947 debug_out (" . "); | |
| 2948 debug_p4 (obj); | |
| 2949 debug_out (")"); | |
| 2950 } | |
| 2951 } | |
| 2952 else if (VECTORP (obj)) | |
| 2953 { | |
| 2954 int size = XVECTOR_LENGTH (obj); | |
| 2955 int i; | |
| 2956 int first = 1; | |
| 2957 | |
| 2958 for (i = 0; i < size; i++) | |
| 2959 { | |
| 2960 debug_out (first ? "[" : " "); | |
| 2961 first = 0; | |
| 2962 debug_p4 (XVECTOR_DATA (obj)[i]); | |
| 2963 debug_out ("]"); | |
| 2964 } | |
| 2965 } | |
| 2966 else if (SYMBOLP (obj)) | |
| 2967 { | |
| 2968 Lisp_Object name = XSYMBOL_NAME (obj); | |
| 2969 if (!STRINGP (name)) | |
| 2970 debug_out ("<<bad symbol>>"); | |
| 2971 else | |
| 2972 debug_out ("%s", XSTRING_DATA (name)); | |
| 2973 } | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2974 else if (FIXNUMP (obj)) |
| 1204 | 2975 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2976 debug_out ("%ld", XFIXNUM (obj)); |
| 1204 | 2977 } |
| 2978 else if (FLOATP (obj)) | |
| 2979 { | |
| 2980 debug_out ("%g", XFLOAT_DATA (obj)); | |
| 2981 } | |
| 2982 else | |
| 2983 { | |
| 2984 struct lrecord_header *header = | |
| 2985 (struct lrecord_header *) XPNTR (obj); | |
| 2986 | |
| 2987 if (header->type >= lrecord_type_last_built_in_type) | |
| 2988 debug_out ("<< bad object type=%d 0x%lx>>", header->type, | |
| 2989 (EMACS_INT) header); | |
| 2990 else | |
| 3063 | 2991 debug_out ("#<%s addr=0x%lx uid=0x%lx>", |
| 2720 | 2992 LHEADER_IMPLEMENTATION (header)->name, |
| 3063 | 2993 (EMACS_INT) header, |
| 2720 | 2994 (EMACS_INT) ((struct lrecord_header *) header)->uid); |
| 1204 | 2995 } |
| 2996 } | |
| 2997 | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2998 static int |
| 1346 | 2999 ext_print_begin (int dest) |
| 3000 { | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3001 int depth = begin_inhibit_non_essential_conversion_operations (); |
| 1346 | 3002 if (dest & EXT_PRINT_ALTERNATE) |
| 3003 alternate_do_pointer = 0; | |
| 3004 if (dest & (EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) | |
| 3005 stdout_clear_before_next_output = 1; | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3006 return depth; |
| 1346 | 3007 } |
| 3008 | |
| 3009 static void | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3010 ext_print_end (int dest, int depth) |
| 1346 | 3011 { |
| 3012 if (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) | |
| 3013 external_out (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | | |
| 3014 EXT_PRINT_STDOUT), "\n"); | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3015 unbind_to (depth); |
| 1346 | 3016 } |
| 3017 | |
| 3018 static void | |
| 3019 external_debug_print (Lisp_Object object, int dest) | |
| 3020 { | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3021 int depth = ext_print_begin (dest); |
| 1346 | 3022 debug_prin1 (object, dest); |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3023 ext_print_end (dest, depth); |
| 1346 | 3024 } |
| 3025 | |
| 1204 | 3026 void |
| 3027 debug_p3 (Lisp_Object obj) | |
| 3028 { | |
| 3029 debug_p4 (obj); | |
| 3030 debug_out ("\n"); | |
| 3031 } | |
| 3032 | |
| 3033 void | |
| 428 | 3034 debug_print (Lisp_Object debug_print_obj) |
| 3035 { | |
| 1346 | 3036 external_debug_print (debug_print_obj, EXT_PRINT_ALL); |
| 428 | 3037 } |
| 3038 | |
|
5189
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3039 /* Printf-style output when the objects being printed are Lisp objects. |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3040 Calling style is e.g. |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3041 |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3042 debug_out_lisp ("Called foo(%s %s)\n", 2, arg0, arg1) |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3043 */ |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3044 |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3045 void |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3046 debug_out_lisp (const CIbyte *format, int nargs, ...) |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3047 { |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3048 /* This function cannot GC, since GC is forbidden */ |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3049 struct debug_bindings bindings; |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3050 int specdepth = debug_print_enter (&bindings); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3051 Lisp_Object *args = alloca_array (Lisp_Object, nargs); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3052 va_list va; |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3053 int i; |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3054 Ibyte *msgout; |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3055 |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3056 va_start (va, nargs); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3057 for (i = 0; i < nargs; i++) |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3058 args[i] = va_arg (va, Lisp_Object); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3059 va_end (va); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3060 msgout = emacs_vsprintf_malloc_lisp (format, Qnil, nargs, args, NULL); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3061 debug_out ("%s", msgout); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3062 xfree (msgout); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3063 unbind_to (specdepth); |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3064 } |
|
b65692aa90d8
Cosmetic XFT-code fixes, some variable renamings
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3065 |
| 1204 | 3066 /* Getting tired of typing debug_print() ... */ |
| 3067 void dp (Lisp_Object debug_print_obj); | |
| 3068 void | |
| 3069 dp (Lisp_Object debug_print_obj) | |
| 3070 { | |
| 3071 debug_print (debug_print_obj); | |
| 3072 } | |
| 3073 | |
| 1346 | 3074 /* Alternate debug printer: Return a char * pointer to the output */ |
| 3075 char *dpa (Lisp_Object debug_print_obj); | |
| 3076 char * | |
| 3077 dpa (Lisp_Object debug_print_obj) | |
| 3078 { | |
| 3079 external_debug_print (debug_print_obj, EXT_PRINT_ALTERNATE); | |
| 3080 | |
| 3081 return alternate_do_string; | |
| 3082 } | |
| 3083 | |
| 428 | 3084 /* Debugging kludge -- unbuffered */ |
| 3085 /* This function provided for the benefit of the debugger. */ | |
| 3086 void | |
| 3087 debug_backtrace (void) | |
| 3088 { | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3089 /* This function cannot GC, since GC is forbidden */ |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3090 struct debug_bindings bindings; |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3091 int specdepth = debug_print_enter (&bindings); |
| 428 | 3092 |
| 3093 Fbacktrace (Qexternal_debugging_output, Qt); | |
| 3094 stderr_out ("\n"); | |
| 3095 | |
| 802 | 3096 unbind_to (specdepth); |
| 428 | 3097 } |
| 3098 | |
| 1204 | 3099 /* Getting tired of typing debug_backtrace() ... */ |
| 3100 void db (void); | |
| 3101 void | |
| 3102 db (void) | |
| 3103 { | |
| 3104 debug_backtrace (); | |
| 3105 } | |
| 3106 | |
| 428 | 3107 void |
| 3108 debug_short_backtrace (int length) | |
| 3109 { | |
| 3110 int first = 1; | |
| 3111 struct backtrace *bt = backtrace_list; | |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3112 |
| 771 | 3113 debug_out (" ["); |
| 428 | 3114 while (length > 0 && bt) |
| 3115 { | |
| 3116 if (!first) | |
| 3117 { | |
| 771 | 3118 debug_out (", "); |
| 428 | 3119 } |
| 3120 if (COMPILED_FUNCTIONP (*bt->function)) | |
| 3121 { | |
| 1346 | 3122 #if defined (COMPILED_FUNCTION_ANNOTATION_HACK) |
| 428 | 3123 Lisp_Object ann = |
| 3124 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function)); | |
| 3125 #else | |
| 3126 Lisp_Object ann = Qnil; | |
| 3127 #endif | |
| 3128 if (!NILP (ann)) | |
| 3129 { | |
| 771 | 3130 debug_out ("<compiled-function from "); |
| 1346 | 3131 debug_prin1 (ann, EXT_PRINT_ALL); |
| 771 | 3132 debug_out (">"); |
| 428 | 3133 } |
| 3134 else | |
| 3135 { | |
| 771 | 3136 debug_out ("<compiled-function of unknown origin>"); |
| 428 | 3137 } |
| 3138 } | |
| 3139 else | |
| 1346 | 3140 debug_prin1 (*bt->function, EXT_PRINT_ALL); |
| 428 | 3141 first = 0; |
| 3142 length--; | |
| 3143 bt = bt->next; | |
| 3144 } | |
| 771 | 3145 debug_out ("]\n"); |
| 428 | 3146 } |
| 3147 | |
| 3148 | |
| 3149 void | |
| 3150 syms_of_print (void) | |
| 3151 { | |
| 563 | 3152 DEFSYMBOL (Qstandard_output); |
| 428 | 3153 |
| 563 | 3154 DEFSYMBOL (Qprint_length); |
| 428 | 3155 |
| 563 | 3156 DEFSYMBOL (Qprint_string_length); |
| 428 | 3157 |
| 563 | 3158 DEFSYMBOL (Qdisplay_error); |
| 3159 DEFSYMBOL (Qprint_message_label); | |
|
5772
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
3160 DEFSYMBOL (Qwrite_sequence); |
| 428 | 3161 |
| 3162 DEFSUBR (Fprin1); | |
| 3163 DEFSUBR (Fprin1_to_string); | |
| 3164 DEFSUBR (Fprinc); | |
| 3165 DEFSUBR (Fprint); | |
| 3166 DEFSUBR (Ferror_message_string); | |
| 3167 DEFSUBR (Fdisplay_error); | |
| 3168 DEFSUBR (Fterpri); | |
| 3169 DEFSUBR (Fwrite_char); | |
|
5772
cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5677
diff
changeset
|
3170 DEFSUBR (Fwrite_sequence); |
| 428 | 3171 DEFSUBR (Falternate_debugging_output); |
| 1346 | 3172 DEFSUBR (Fset_device_clear_left_side); |
| 3173 DEFSUBR (Fdevice_left_side_clear_p); | |
| 428 | 3174 DEFSUBR (Fexternal_debugging_output); |
| 3175 DEFSUBR (Fopen_termscript); | |
| 563 | 3176 DEFSYMBOL (Qexternal_debugging_output); |
| 3177 DEFSYMBOL (Qalternate_debugging_output); | |
| 442 | 3178 #ifdef HAVE_MS_WINDOWS |
| 563 | 3179 DEFSYMBOL (Qmswindows_debugging_output); |
| 442 | 3180 #endif |
| 428 | 3181 DEFSUBR (Fwith_output_to_temp_buffer); |
| 3182 } | |
| 3183 | |
| 3184 void | |
| 3185 reinit_vars_of_print (void) | |
| 3186 { | |
| 3187 alternate_do_pointer = 0; | |
| 3188 } | |
| 3189 | |
| 3190 void | |
| 3191 vars_of_print (void) | |
| 3192 { | |
| 3193 DEFVAR_LISP ("standard-output", &Vstandard_output /* | |
| 3194 Output stream `print' uses by default for outputting a character. | |
| 3195 This may be any function of one argument. | |
| 3196 It may also be a buffer (output is inserted before point) | |
| 3197 or a marker (output is inserted and the marker is advanced) | |
| 3198 or the symbol t (output appears in the minibuffer line). | |
| 3199 */ ); | |
| 3200 Vstandard_output = Qt; | |
| 3201 | |
| 3202 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /* | |
| 3203 The format descriptor string that lisp uses to print floats. | |
| 3204 This is a %-spec like those accepted by `printf' in C, | |
| 3205 but with some restrictions. It must start with the two characters `%.'. | |
| 3206 After that comes an integer precision specification, | |
| 3207 and then a letter which controls the format. | |
| 3208 The letters allowed are `e', `f' and `g'. | |
| 3209 Use `e' for exponential notation "DIG.DIGITSeEXPT" | |
| 3210 Use `f' for decimal point notation "DIGITS.DIGITS". | |
| 3211 Use `g' to choose the shorter of those two formats for the number at hand. | |
| 3212 The precision in any of these cases is the number of digits following | |
| 3213 the decimal point. With `f', a precision of 0 means to omit the | |
| 3214 decimal point. 0 is not allowed with `f' or `g'. | |
| 3215 | |
| 3216 A value of nil means to use `%.16g'. | |
| 3217 | |
| 3218 Regardless of the value of `float-output-format', a floating point number | |
| 3219 will never be printed in such a way that it is ambiguous with an integer; | |
| 3220 that is, a floating-point number will always be printed with a decimal | |
| 3221 point and/or an exponent, even if the digits following the decimal point | |
| 3222 are all zero. This is to preserve read-equivalence. | |
| 3223 */ ); | |
| 3224 Vfloat_output_format = Qnil; | |
| 3225 | |
| 3226 DEFVAR_LISP ("print-length", &Vprint_length /* | |
| 3227 Maximum length of list or vector to print before abbreviating. | |
| 3228 A value of nil means no limit. | |
| 3229 */ ); | |
| 3230 Vprint_length = Qnil; | |
| 3231 | |
| 3232 DEFVAR_LISP ("print-string-length", &Vprint_string_length /* | |
| 3233 Maximum length of string to print before abbreviating. | |
| 3234 A value of nil means no limit. | |
| 3235 */ ); | |
| 3236 Vprint_string_length = Qnil; | |
| 3237 | |
| 3238 DEFVAR_LISP ("print-level", &Vprint_level /* | |
| 3239 Maximum depth of list nesting to print before abbreviating. | |
| 3240 A value of nil means no limit. | |
| 3241 */ ); | |
| 3242 Vprint_level = Qnil; | |
| 3243 | |
| 3244 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /* | |
| 3245 Non-nil means print newlines in strings as backslash-n. | |
| 3246 */ ); | |
| 3247 print_escape_newlines = 0; | |
| 3248 | |
| 3249 DEFVAR_BOOL ("print-readably", &print_readably /* | |
| 3250 If non-nil, then all objects will be printed in a readable form. | |
| 3251 If an object has no readable representation, then an error is signalled. | |
| 3252 When print-readably is true, compiled-function objects will be written in | |
| 3253 #[...] form instead of in #<compiled-function [...]> form, and two-element | |
| 3254 lists of the form (quote object) will be written as the equivalent 'object. | |
| 3255 Do not SET this variable; bind it instead. | |
| 3256 */ ); | |
| 3257 print_readably = 0; | |
| 3258 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3259 DEFVAR_BOOL ("print-gensym", &print_gensym /* |
| 428 | 3260 If non-nil, then uninterned symbols will be printed specially. |
| 3261 Uninterned symbols are those which are not present in `obarray', that is, | |
| 3262 those which were made with `make-symbol' or by calling `intern' with a | |
| 3263 second argument. | |
| 3264 | |
| 3265 When print-gensym is true, such symbols will be preceded by "#:", | |
| 3266 which causes the reader to create a new symbol instead of interning | |
| 3267 and returning an existing one. Beware: the #: syntax creates a new | |
| 3268 symbol each time it is seen, so if you print an object which contains | |
| 3269 two pointers to the same uninterned symbol, `read' will not duplicate | |
| 3270 that structure. | |
| 3271 | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3272 If the value of `print-continuous-numbering' is non-nil, the table used by |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3273 `print-gensym' and `print-circle' (which see) will not be reset on entry to |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3274 and exit from printing functions, so that the use of #...# and #...= can |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3275 carry over for several separately printed objects. |
| 428 | 3276 */ ); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3277 print_gensym = 1; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3278 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3279 DEFVAR_BOOL ("print-circle", &print_circle /* |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3280 Non-nil means print recursive structures using #N= and #N# syntax. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3281 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3282 If nil, XEmacs detects recursive structures and truncates them in an |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3283 unreadable fashion. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3284 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3285 If non-nil, shared substructures anywhere in the structure are printed |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3286 with `#N=' before the first occurrence (in the order of the print |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3287 representation) and `#N#' in place of each subsequent occurrence, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3288 where N is a positive decimal integer. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3289 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3290 If the value of `print-continuous-numbering' is non-nil, the table used by |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3291 `print-gensym' (which see) and `print-circle' will not be reset on entry to |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3292 and exit from printing functions, so that the use of #...# and #...= can |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3293 carry over for several separately printed objects. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3294 */); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3295 print_circle = 0; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3296 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3297 DEFVAR_BOOL_MAGIC ("print-continuous-numbering", |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3298 &print_continuous_numbering /* |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3299 Non-nil means number continuously across print calls, mostly for symbols. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3300 This affects the numbers printed for #N= labels and #M# references. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3301 See also `print-circle' and `print-gensym'. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3302 This variable should not be set with `setq'; bind it with a `let' instead. |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3303 */ , |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3304 print_continuous_numbering_changed); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3305 print_continuous_numbering = 0; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3306 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3307 staticpro (&Vprint_number_table); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5420
diff
changeset
|
3308 Vprint_number_table = make_lisp_hash_table (16, HASH_TABLE_KEY_WEAK, Qeq); |
| 428 | 3309 |
| 3310 DEFVAR_LISP ("print-message-label", &Vprint_message_label /* | |
| 3311 Label for minibuffer messages created with `print'. This should | |
| 3312 generally be bound with `let' rather than set. (See `display-message'.) | |
| 3313 */ ); | |
| 3314 Vprint_message_label = Qprint; | |
| 1957 | 3315 |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3316 /* The exact size doesn't matter since we realloc when necessary. |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3317 Use CIbyte instead of Ibyte so that debuggers show the associated |
|
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3318 string automatically. */ |
| 1957 | 3319 alternate_do_size = 5000; |
|
5014
c2e0c3af5fe3
cleanups to debug-print, try harder to make it work during GC
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3320 alternate_do_string = xnew_array (CIbyte, 5000); |
| 428 | 3321 } |