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