Mercurial > hg > xemacs-beta
annotate src/lread.c @ 5887:6eca500211f4
Prototype for X509_check_host() has changed, detect this in configure.ac
ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* configure.ac:
If X509_check_host() is available, check the number of arguments
it takes. Don't use it if it takes any number of arguments other
than five. Also don't use it if <openssl/x509v3.h> does not
declare it, since if that is so there is no portable way to tell
how many arguments it should take, and so we would end up smashing
the stack.
* configure: Regenerate.
src/ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* tls.c:
#include <openssl/x509v3.h> for its prototype for
X509_check_host().
* tls.c (tls_open):
Pass the new fifth argument to X509_check_host().
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 09 Apr 2015 14:27:02 +0100 |
| parents | 750fab17b299 |
| children | 6174848f3e6c |
| rev | line source |
|---|---|
| 428 | 1 /* Lisp parsing and input streams. |
| 2 Copyright (C) 1985-1989, 1992-1995 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Tinker Systems. | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
4 Copyright (C) 1996, 2001, 2002, 2003, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5247
diff
changeset
|
8 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 9 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:
5247
diff
changeset
|
10 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:
5247
diff
changeset
|
11 option) any later version. |
| 428 | 12 |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 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:
5247
diff
changeset
|
19 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 20 |
| 21 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
| 22 | |
| 23 /* This file has been Mule-ized. */ | |
| 24 | |
| 25 #include <config.h> | |
| 26 #include "lisp.h" | |
| 27 | |
| 28 #include "buffer.h" | |
| 29 #include "bytecode.h" | |
| 30 #include "elhash.h" | |
| 1292 | 31 #include "file-coding.h" |
| 428 | 32 #include "lstream.h" |
| 33 #include "opaque.h" | |
| 1292 | 34 #include "profile.h" |
| 3439 | 35 #include "charset.h" /* For Funicode_to_char. */ |
| 428 | 36 |
| 37 #include "sysfile.h" | |
| 38 #include "sysfloat.h" | |
| 771 | 39 #ifdef WIN32_NATIVE |
| 40 #include "syswindows.h" | |
| 41 #endif | |
| 428 | 42 |
| 43 Lisp_Object Qread_char, Qstandard_input; | |
| 44 Lisp_Object Qvariable_documentation; | |
| 45 #define LISP_BACKQUOTES | |
| 46 #ifdef LISP_BACKQUOTES | |
| 47 /* | |
| 48 Nonzero means inside a new-style backquote | |
| 49 with no surrounding parentheses. | |
| 50 Fread initializes this to zero, so we need not specbind it | |
| 51 or worry about what happens to it when there is an error. | |
| 52 | |
| 53 XEmacs: | |
| 54 Nested backquotes are perfectly legal and fail utterly with | |
| 55 this silliness. */ | |
| 56 static int new_backquote_flag, old_backquote_flag; | |
| 57 Lisp_Object Qbackquote, Qbacktick, Qcomma, Qcomma_at, Qcomma_dot; | |
| 58 #endif | |
| 59 Lisp_Object Qvariable_domain; /* I18N3 */ | |
| 60 Lisp_Object Vvalues, Vstandard_input, Vafter_load_alist; | |
| 2548 | 61 Lisp_Object Vload_suppress_alist; |
| 62 Lisp_Object Qload, Qload_internal, Qfset; | |
| 428 | 63 |
| 64 /* Hash-table that maps directory names to hashes of their contents. */ | |
| 65 static Lisp_Object Vlocate_file_hash_table; | |
| 66 | |
| 67 Lisp_Object Qexists, Qreadable, Qwritable, Qexecutable; | |
| 68 | |
| 69 /* See read_escape() for an explanation of this. */ | |
| 70 #if 0 | |
| 71 int fail_on_bucky_bit_character_escapes; | |
| 72 #endif | |
| 73 | |
| 74 /* This symbol is also used in fns.c */ | |
| 75 #define FEATUREP_SYNTAX | |
| 76 | |
| 77 #ifdef FEATUREP_SYNTAX | |
| 78 Lisp_Object Qfeaturep; | |
| 79 #endif | |
| 80 | |
| 81 /* non-zero if inside `load' */ | |
| 82 int load_in_progress; | |
| 83 | |
| 84 /* Whether Fload_internal() should check whether the .el is newer | |
| 85 when loading .elc */ | |
| 86 int load_warn_when_source_newer; | |
| 87 /* Whether Fload_internal() should check whether the .elc doesn't exist */ | |
| 88 int load_warn_when_source_only; | |
| 89 /* Whether Fload_internal() should ignore .elc files when no suffix is given */ | |
| 90 int load_ignore_elc_files; | |
| 1123 | 91 /* Whether Fload_internal() should ignore out-of-date .elc files when no |
| 92 suffix is given */ | |
| 93 int load_ignore_out_of_date_elc_files; | |
| 94 /* Always display messages showing when a file is loaded, regardless of | |
| 95 whether the flag to `load' tries to suppress them. */ | |
| 96 int load_always_display_messages; | |
| 97 /* Show the full path in loading messages. */ | |
| 98 int load_show_full_path_in_messages; | |
| 428 | 99 |
| 100 /* Search path for files to be loaded. */ | |
| 101 Lisp_Object Vload_path; | |
| 102 | |
| 103 /* Search path for files when dumping. */ | |
| 104 /* Lisp_Object Vdump_load_path; */ | |
| 105 | |
| 106 /* This is the user-visible association list that maps features to | |
| 107 lists of defs in their load files. */ | |
| 108 Lisp_Object Vload_history; | |
| 109 | |
| 110 /* This is used to build the load history. */ | |
| 111 Lisp_Object Vcurrent_load_list; | |
| 112 | |
| 113 /* Name of file actually being read by `load'. */ | |
| 114 Lisp_Object Vload_file_name; | |
| 115 | |
| 116 /* Same as Vload_file_name but not Lisp-accessible. This ensures that | |
| 117 our #$ checks are reliable. */ | |
| 118 Lisp_Object Vload_file_name_internal; | |
| 119 | |
| 120 /* Function to use for reading, in `load' and friends. */ | |
| 121 Lisp_Object Vload_read_function; | |
| 122 | |
| 123 /* The association list of objects read with the #n=object form. | |
| 124 Each member of the list has the form (n . object), and is used to | |
| 125 look up the object for the corresponding #n# construct. | |
| 126 It must be set to nil before all top-level calls to read0. */ | |
| 127 Lisp_Object Vread_objects; | |
| 128 | |
| 129 /* Nonzero means load should forcibly load all dynamic doc strings. */ | |
| 130 /* Note that this always happens (with some special behavior) when | |
| 131 purify_flag is set. */ | |
| 132 static int load_force_doc_strings; | |
| 133 | |
| 134 /* List of descriptors now open for Fload_internal. */ | |
| 135 static Lisp_Object Vload_descriptor_list; | |
| 136 | |
| 137 /* In order to implement "load_force_doc_strings", we keep | |
| 138 a list of all the compiled-function objects and such | |
| 139 that we have created in the process of loading this file. | |
| 140 See the rant below. | |
| 141 | |
| 142 We specbind this just like Vload_file_name, so there's no | |
| 143 problems with recursive loading. */ | |
| 144 static Lisp_Object Vload_force_doc_string_list; | |
| 145 | |
| 146 /* A resizing-buffer stream used to temporarily hold data while reading */ | |
| 147 static Lisp_Object Vread_buffer_stream; | |
| 148 | |
| 149 static int load_byte_code_version; | |
| 150 | |
| 151 /* An array describing all known built-in structure types */ | |
| 152 static structure_type_dynarr *the_structure_type_dynarr; | |
| 153 | |
| 154 #if 0 /* FSF stuff */ | |
| 155 /* For use within read-from-string (this reader is non-reentrant!!) */ | |
| 156 static int read_from_string_index; | |
| 157 static int read_from_string_limit; | |
| 158 #endif | |
| 159 | |
| 160 #if 0 /* More FSF implementation kludges. */ | |
| 161 /* In order to implement load-force-doc-string, FSF saves the | |
| 162 #@-quoted string when it's seen, and goes back and retrieves | |
| 163 it later. | |
| 164 | |
| 165 This approach is not only kludgy, but it in general won't work | |
| 166 correctly because there's no stack of remembered #@-quoted-strings | |
| 167 and those strings don't generally appear in the file in the same | |
| 168 order as their #$ references. (Yes, that is amazingly stupid too. | |
| 169 | |
| 170 It would be trivially easy to always encode the #@ string | |
| 171 [which is a comment, anyway] in the middle of the (#$ . INT) cons | |
| 172 reference. That way, it would be really easy to implement | |
| 173 load-force-doc-string in a non-kludgy way by just retrieving the | |
| 174 string immediately, because it's delivered on a silver platter.) | |
| 175 | |
| 176 And finally, this stupid approach doesn't work under Mule, or | |
| 177 under MS-DOS or Windows NT, or under VMS, or any other place | |
| 178 where you either can't do an ftell() or don't get back a byte | |
| 179 count. | |
| 180 | |
| 181 Oh, and one more lossage in this approach: If you attempt to | |
| 182 dump any ELC files that were compiled with `byte-compile-dynamic' | |
| 183 (as opposed to just `byte-compile-dynamic-docstring'), you | |
| 184 get hosed. FMH! (as the illustrious JWZ was prone to utter) | |
| 185 | |
| 186 The approach we use is clean, solves all of these problems, and is | |
| 187 probably easier to implement anyway. We just save a list of all | |
| 188 the containing objects that have (#$ . INT) conses in them (this | |
| 189 will only be compiled-function objects and lists), and when the | |
| 190 file is finished loading, we go through and fill in all the | |
| 814 | 191 doc strings at once. --ben */ |
| 428 | 192 |
| 193 /* This contains the last string skipped with #@. */ | |
| 194 static char *saved_doc_string; | |
| 195 /* Length of buffer allocated in saved_doc_string. */ | |
| 196 static int saved_doc_string_size; | |
| 197 /* Length of actual data in saved_doc_string. */ | |
| 198 static int saved_doc_string_length; | |
| 199 /* This is the file position that string came from. */ | |
| 200 static int saved_doc_string_position; | |
| 201 #endif | |
| 202 | |
| 1123 | 203 static int locate_file_open_or_access_file (Ibyte *fn, int access_mode); |
| 428 | 204 EXFUN (Fread_from_string, 3); |
| 205 | |
| 206 /* When errors are signaled, the actual readcharfun should not be used | |
| 207 as an argument if it is an lstream, so that lstreams don't escape | |
| 208 to the Lisp level. */ | |
| 1261 | 209 #define READCHARFUN_MAYBE(x) (LSTREAMP (x) \ |
| 210 ? (build_msg_string ("internal input stream")) \ | |
| 428 | 211 : (x)) |
| 212 | |
| 213 | |
| 2268 | 214 static DECLARE_DOESNT_RETURN (read_syntax_error (const char *)); |
| 215 | |
| 428 | 216 static DOESNT_RETURN |
| 442 | 217 read_syntax_error (const char *string) |
| 428 | 218 { |
| 563 | 219 signal_error (Qinvalid_read_syntax, string, Qunbound); |
| 428 | 220 } |
| 221 | |
| 222 static Lisp_Object | |
| 442 | 223 continuable_read_syntax_error (const char *string) |
| 428 | 224 { |
| 563 | 225 return signal_continuable_error (Qinvalid_read_syntax, string, Qunbound); |
| 428 | 226 } |
| 227 | |
| 228 | |
| 229 /* Handle unreading and rereading of characters. */ | |
| 867 | 230 static Ichar |
| 428 | 231 readchar (Lisp_Object readcharfun) |
| 232 { | |
| 233 /* This function can GC */ | |
| 234 | |
| 235 if (BUFFERP (readcharfun)) | |
| 236 { | |
| 867 | 237 Ichar c; |
| 428 | 238 struct buffer *b = XBUFFER (readcharfun); |
| 239 | |
| 240 if (!BUFFER_LIVE_P (b)) | |
| 563 | 241 invalid_operation ("Reading from killed buffer", Qunbound); |
| 428 | 242 |
| 243 if (BUF_PT (b) >= BUF_ZV (b)) | |
| 244 return -1; | |
| 245 c = BUF_FETCH_CHAR (b, BUF_PT (b)); | |
| 246 BUF_SET_PT (b, BUF_PT (b) + 1); | |
| 247 | |
| 248 return c; | |
| 249 } | |
| 250 else if (LSTREAMP (readcharfun)) | |
| 251 { | |
| 867 | 252 Ichar c = Lstream_get_ichar (XLSTREAM (readcharfun)); |
| 428 | 253 #ifdef DEBUG_XEMACS /* testing Mule */ |
| 254 static int testing_mule = 0; /* Change via debugger */ | |
| 444 | 255 if (testing_mule) |
| 256 { | |
| 257 if (c >= 0x20 && c <= 0x7E) stderr_out ("%c", c); | |
| 258 else if (c == '\n') stderr_out ("\\n\n"); | |
| 259 else stderr_out ("\\%o ", c); | |
| 260 } | |
| 261 #endif /* testing Mule */ | |
| 428 | 262 return c; |
| 263 } | |
| 264 else if (MARKERP (readcharfun)) | |
| 265 { | |
| 867 | 266 Ichar c; |
| 665 | 267 Charbpos mpos = marker_position (readcharfun); |
| 428 | 268 struct buffer *inbuffer = XMARKER (readcharfun)->buffer; |
| 269 | |
| 270 if (mpos >= BUF_ZV (inbuffer)) | |
| 271 return -1; | |
| 272 c = BUF_FETCH_CHAR (inbuffer, mpos); | |
| 273 set_marker_position (readcharfun, mpos + 1); | |
| 274 return c; | |
| 275 } | |
| 276 else | |
| 277 { | |
| 278 Lisp_Object tem = call0 (readcharfun); | |
| 279 | |
| 280 if (!CHAR_OR_CHAR_INTP (tem)) | |
| 281 return -1; | |
| 282 return XCHAR_OR_CHAR_INT (tem); | |
| 283 } | |
| 284 } | |
| 285 | |
| 286 /* Unread the character C in the way appropriate for the stream READCHARFUN. | |
| 287 If the stream is a user function, call it with the char as argument. */ | |
| 288 | |
| 289 static void | |
| 867 | 290 unreadchar (Lisp_Object readcharfun, Ichar c) |
| 428 | 291 { |
| 292 if (c == -1) | |
| 293 /* Don't back up the pointer if we're unreading the end-of-input mark, | |
| 294 since readchar didn't advance it when we read it. */ | |
| 295 ; | |
| 296 else if (BUFFERP (readcharfun)) | |
| 297 BUF_SET_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1); | |
| 298 else if (LSTREAMP (readcharfun)) | |
| 299 { | |
| 867 | 300 Lstream_unget_ichar (XLSTREAM (readcharfun), c); |
| 428 | 301 #ifdef DEBUG_XEMACS /* testing Mule */ |
| 302 { | |
| 303 static int testing_mule = 0; /* Set this using debugger */ | |
| 304 if (testing_mule) | |
| 305 fprintf (stderr, | |
| 306 (c >= 0x20 && c <= 0x7E) ? "UU%c" : | |
|
5762
427a72c6ee17
Eliminate several compiler (clang) warnings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5677
diff
changeset
|
307 ((c == '\n') ? "UU\\n%c" : "UU\\%o"), c); |
| 428 | 308 } |
| 309 #endif | |
| 310 } | |
| 311 else if (MARKERP (readcharfun)) | |
| 312 set_marker_position (readcharfun, marker_position (readcharfun) - 1); | |
| 313 else | |
| 314 call1 (readcharfun, make_char (c)); | |
| 315 } | |
| 316 | |
| 317 static Lisp_Object read0 (Lisp_Object readcharfun); | |
| 318 static Lisp_Object read1 (Lisp_Object readcharfun); | |
| 319 static Lisp_Object read_list (Lisp_Object readcharfun, | |
| 867 | 320 Ichar terminator, |
| 428 | 321 int allow_dotted_lists, |
| 322 int check_for_doc_references); | |
| 323 | |
| 324 static void readevalloop (Lisp_Object readcharfun, | |
| 325 Lisp_Object sourcefile, | |
| 326 Lisp_Object (*evalfun) (Lisp_Object), | |
| 327 int printflag); | |
| 328 | |
| 329 static Lisp_Object | |
| 330 load_unwind (Lisp_Object stream) /* used as unwind-protect function in load */ | |
| 331 { | |
| 332 Lstream_close (XLSTREAM (stream)); | |
| 333 return Qnil; | |
| 334 } | |
| 335 | |
| 2548 | 336 /* Check if NONRELOC/RELOC (an absolute filename) is suppressed according |
| 337 to load-suppress-alist. */ | |
| 338 static int | |
| 339 check_if_suppressed (Ibyte *nonreloc, Lisp_Object reloc) | |
| 340 { | |
| 341 Bytecount len; | |
| 342 | |
| 343 if (!NILP (reloc)) | |
| 344 { | |
| 345 nonreloc = XSTRING_DATA (reloc); | |
| 346 len = XSTRING_LENGTH (reloc); | |
| 347 } | |
| 348 else | |
| 349 len = qxestrlen (nonreloc); | |
| 350 | |
| 351 if (len >= 4 && !qxestrcmp_ascii (nonreloc + len - 4, ".elc")) | |
| 352 len -= 4; | |
| 353 else if (len >= 3 && !qxestrcmp_ascii (nonreloc + len - 3, ".el")) | |
| 354 len -= 3; | |
| 355 | |
| 2567 | 356 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
357 EXTERNAL_LIST_LOOP_2 (cons, Vload_suppress_alist) |
| 2567 | 358 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
359 if (CONSP (cons) && STRINGP (XCAR (cons))) |
| 2567 | 360 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
361 Lisp_Object name = XCAR (cons); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
362 if (XSTRING_LENGTH (name) == len && |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
363 !memcmp (XSTRING_DATA (name), nonreloc, len)) |
| 2567 | 364 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
365 struct gcpro gcpro1; |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
366 Lisp_Object val; |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
367 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
368 GCPRO1 (reloc); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
369 val = IGNORE_MULTIPLE_VALUES (Feval (XCDR (cons))); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
370 UNGCPRO; |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
371 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
372 if (!NILP (val)) |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
373 return 1; |
| 2567 | 374 } |
| 375 } | |
| 376 } | |
| 377 } | |
| 2548 | 378 |
| 379 return 0; | |
| 380 } | |
| 381 | |
| 428 | 382 /* The plague is coming. |
| 383 | |
| 384 Ring around the rosy, pocket full of posy, | |
| 385 Ashes ashes, they all fall down. | |
| 386 */ | |
| 387 void | |
| 388 ebolify_bytecode_constants (Lisp_Object vector) | |
| 389 { | |
| 390 int len = XVECTOR_LENGTH (vector); | |
| 391 int i; | |
| 392 | |
| 393 for (i = 0; i < len; i++) | |
| 394 { | |
| 395 Lisp_Object el = XVECTOR_DATA (vector)[i]; | |
| 396 | |
| 397 /* We don't check for `eq', `equal', and the others that have | |
| 398 bytecode opcodes. This might lose if someone passes #'eq or | |
| 399 something to `funcall', but who would really do that? As | |
| 400 they say in law, we've made a "good-faith effort" to | |
| 401 unfuckify ourselves. And doing it this way avoids screwing | |
| 402 up args to `make-hash-table' and such. As it is, we have to | |
| 403 add an extra Ebola check in decode_weak_list_type(). --ben */ | |
| 404 if (EQ (el, Qassoc)) el = Qold_assoc; | |
| 405 else if (EQ (el, Qdelq)) el = Qold_delq; | |
| 406 #if 0 | |
| 407 /* I think this is a bad idea because it will probably mess | |
| 408 with keymap code. */ | |
| 409 else if (EQ (el, Qdelete)) el = Qold_delete; | |
| 410 #endif | |
| 411 else if (EQ (el, Qrassq)) el = Qold_rassq; | |
| 412 else if (EQ (el, Qrassoc)) el = Qold_rassoc; | |
| 413 | |
| 414 XVECTOR_DATA (vector)[i] = el; | |
| 415 } | |
| 416 } | |
| 417 | |
| 418 static Lisp_Object | |
| 558 | 419 pas_de_holgazan_ici (int fd, Lisp_Object victim) |
| 428 | 420 { |
| 421 Lisp_Object tem; | |
| 422 EMACS_INT pos; | |
| 423 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
424 if (!FIXNUMP (XCDR (victim))) |
| 563 | 425 invalid_byte_code ("Bogus doc string reference", victim); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
426 pos = XFIXNUM (XCDR (victim)); |
| 428 | 427 if (pos < 0) |
| 428 pos = -pos; /* kludge to mark a user variable */ | |
| 814 | 429 tem = unparesseuxify_doc_string (fd, pos, 0, Vload_file_name_internal, 0); |
| 428 | 430 if (!STRINGP (tem)) |
| 563 | 431 signal_error_1 (Qinvalid_byte_code, tem); |
| 428 | 432 return tem; |
| 433 } | |
| 434 | |
| 435 static Lisp_Object | |
| 436 load_force_doc_string_unwind (Lisp_Object oldlist) | |
| 437 { | |
| 438 struct gcpro gcpro1; | |
| 439 Lisp_Object list = Vload_force_doc_string_list; | |
| 440 Lisp_Object tail; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
441 int fd = XFIXNUM (XCAR (Vload_descriptor_list)); |
| 428 | 442 |
| 443 GCPRO1 (list); | |
| 444 /* restore the old value first just in case an error occurs. */ | |
| 445 Vload_force_doc_string_list = oldlist; | |
| 446 | |
| 447 LIST_LOOP (tail, list) | |
| 448 { | |
| 449 Lisp_Object john = Fcar (tail); | |
| 450 if (CONSP (john)) | |
| 451 { | |
| 452 assert (CONSP (XCAR (john))); | |
| 453 assert (!purify_flag); /* should have been handled in read_list() */ | |
| 558 | 454 XCAR (john) = pas_de_holgazan_ici (fd, XCAR (john)); |
| 428 | 455 } |
| 456 else | |
| 457 { | |
| 458 Lisp_Object doc; | |
| 459 | |
| 460 assert (COMPILED_FUNCTIONP (john)); | |
| 461 if (CONSP (XCOMPILED_FUNCTION (john)->instructions)) | |
| 462 { | |
| 463 struct gcpro ngcpro1; | |
| 558 | 464 Lisp_Object juan = (pas_de_holgazan_ici |
| 814 | 465 (fd, |
| 466 XCOMPILED_FUNCTION (john)->instructions)); | |
| 428 | 467 Lisp_Object ivan; |
| 468 | |
| 469 NGCPRO1 (juan); | |
| 470 ivan = Fread (juan); | |
| 471 if (!CONSP (ivan)) | |
| 563 | 472 invalid_byte_code ("invalid lazy-loaded byte code", ivan); |
| 428 | 473 XCOMPILED_FUNCTION (john)->instructions = XCAR (ivan); |
| 474 /* v18 or v19 bytecode file. Need to Ebolify. */ | |
| 475 if (XCOMPILED_FUNCTION (john)->flags.ebolified | |
| 476 && VECTORP (XCDR (ivan))) | |
| 477 ebolify_bytecode_constants (XCDR (ivan)); | |
| 478 XCOMPILED_FUNCTION (john)->constants = XCDR (ivan); | |
| 479 NUNGCPRO; | |
| 480 } | |
| 481 doc = compiled_function_documentation (XCOMPILED_FUNCTION (john)); | |
| 482 if (CONSP (doc)) | |
| 483 { | |
| 484 assert (!purify_flag); /* should have been handled in | |
| 485 read_compiled_function() */ | |
| 558 | 486 doc = pas_de_holgazan_ici (fd, doc); |
| 428 | 487 set_compiled_function_documentation (XCOMPILED_FUNCTION (john), |
| 488 doc); | |
| 489 } | |
| 490 } | |
| 491 } | |
| 492 | |
| 493 if (!NILP (list)) | |
| 494 free_list (list); | |
| 495 | |
| 496 UNGCPRO; | |
| 497 return Qnil; | |
| 498 } | |
| 499 | |
| 500 /* Close all descriptors in use for Fload_internal. | |
| 501 This is used when starting a subprocess. */ | |
| 502 | |
| 503 void | |
| 504 close_load_descs (void) | |
| 505 { | |
| 506 Lisp_Object tail; | |
| 507 LIST_LOOP (tail, Vload_descriptor_list) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
508 retry_close (XFIXNUM (XCAR (tail))); |
| 428 | 509 } |
| 510 | |
| 511 #ifdef I18N3 | |
| 512 Lisp_Object Vfile_domain; | |
| 513 #endif /* I18N3 */ | |
| 514 | |
| 515 DEFUN ("load-internal", Fload_internal, 1, 6, 0, /* | |
| 516 Execute a file of Lisp code named FILE; no coding-system frobbing. | |
| 517 This function is identical to `load' except for the handling of the | |
| 518 CODESYS and USED-CODESYS arguments under XEmacs/Mule. (When Mule | |
| 519 support is not present, both functions are identical and ignore the | |
| 520 CODESYS and USED-CODESYS arguments.) | |
| 521 | |
| 522 If support for Mule exists in this Emacs, the file is decoded | |
| 523 according to CODESYS; if omitted, no conversion happens. If | |
| 524 USED-CODESYS is non-nil, it should be a symbol, and the actual coding | |
| 525 system that was used for the decoding is stored into it. It will in | |
| 526 general be different from CODESYS if CODESYS specifies automatic | |
| 527 encoding detection or end-of-line detection. | |
| 528 */ | |
| 444 | 529 (file, noerror, nomessage, nosuffix, codesys, used_codesys)) |
| 428 | 530 { |
| 531 /* This function can GC */ | |
| 532 int fd = -1; | |
| 533 int speccount = specpdl_depth (); | |
| 534 int source_only = 0; | |
| 1123 | 535 /* NEWER and OLDER are filenames w/o directory, used in loading messages |
| 536 to e.g. warn of newer .el files when the .elc is being loaded. */ | |
| 428 | 537 Lisp_Object newer = Qnil; |
| 1123 | 538 Lisp_Object older = Qnil; |
| 428 | 539 Lisp_Object handler = Qnil; |
| 540 Lisp_Object found = Qnil; | |
| 1292 | 541 Lisp_Object retval; |
| 1123 | 542 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 428 | 543 int reading_elc = 0; |
| 780 | 544 int from_require = EQ (nomessage, Qrequire); |
| 1261 | 545 int message_p = NILP (nomessage) || load_always_display_messages; |
| 428 | 546 struct stat s1, s2; |
| 1261 | 547 Ibyte *spaces = alloca_ibytes (load_in_progress * 2 + 10); |
| 548 int i; | |
| 1292 | 549 PROFILE_DECLARE (); |
| 428 | 550 |
| 1266 | 551 GCPRO4 (file, newer, older, found); |
| 428 | 552 CHECK_STRING (file); |
| 553 | |
| 1292 | 554 PROFILE_RECORD_ENTERING_SECTION (Qload_internal); |
| 555 | |
| 428 | 556 /* If file name is magic, call the handler. */ |
| 557 handler = Ffind_file_name_handler (file, Qload); | |
| 558 if (!NILP (handler)) | |
| 1292 | 559 { |
| 560 retval = call5 (handler, Qload, file, noerror, nomessage, nosuffix); | |
| 561 goto done; | |
| 562 } | |
| 428 | 563 |
| 564 /* Do this after the handler to avoid | |
| 565 the need to gcpro noerror, nomessage and nosuffix. | |
| 566 (Below here, we care only whether they are nil or not.) */ | |
| 567 file = Fsubstitute_in_file_name (file); | |
| 568 if (!NILP (used_codesys)) | |
| 569 CHECK_SYMBOL (used_codesys); | |
| 570 | |
| 1261 | 571 if (noninteractive) |
| 572 { | |
| 573 for (i = 0; i < load_in_progress * 2; i++) | |
| 574 spaces[i] = ' '; | |
| 575 spaces[i] = '\0'; | |
| 576 } | |
| 577 else | |
| 578 spaces[0] = '\0'; | |
| 579 | |
| 428 | 580 /* Avoid weird lossage with null string as arg, |
| 581 since it would try to load a directory as a Lisp file. | |
| 582 Unix truly sucks. */ | |
| 583 if (XSTRING_LENGTH (file) > 0) | |
| 584 { | |
| 867 | 585 Ibyte *foundstr; |
| 428 | 586 int foundlen; |
| 587 | |
| 588 fd = locate_file (Vload_path, file, | |
| 589 ((!NILP (nosuffix)) ? Qnil : | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
590 build_ascstring (load_ignore_elc_files ? ".el:" : |
| 428 | 591 ".elc:.el:")), |
| 592 &found, | |
| 593 -1); | |
| 594 | |
| 595 if (fd < 0) | |
| 596 { | |
| 444 | 597 if (NILP (noerror)) |
| 563 | 598 signal_error (Qfile_error, "Cannot open load file", file); |
| 428 | 599 else |
| 600 { | |
| 1292 | 601 retval = Qnil; |
| 602 goto done; | |
| 428 | 603 } |
| 604 } | |
| 605 | |
| 2367 | 606 foundstr = alloca_ibytes (XSTRING_LENGTH (found) + 1); |
| 771 | 607 qxestrcpy (foundstr, XSTRING_DATA (found)); |
| 608 foundlen = qxestrlen (foundstr); | |
| 428 | 609 |
| 610 /* The omniscient JWZ thinks this is worthless, but I beg to | |
| 611 differ. --ben */ | |
| 612 if (load_ignore_elc_files) | |
| 1123 | 613 newer = Ffile_name_nondirectory (found); |
| 614 else if ((load_warn_when_source_newer || | |
| 615 load_ignore_out_of_date_elc_files) && | |
| 428 | 616 !memcmp (".elc", foundstr + foundlen - 4, 4)) |
| 617 { | |
| 771 | 618 if (! qxe_fstat (fd, &s1)) /* can't fail, right? */ |
| 428 | 619 { |
| 620 int result; | |
| 621 /* temporarily hack the 'c' off the end of the filename */ | |
| 622 foundstr[foundlen - 1] = '\0'; | |
| 771 | 623 result = qxe_stat (foundstr, &s2); |
| 428 | 624 if (result >= 0 && |
| 625 (unsigned) s1.st_mtime < (unsigned) s2.st_mtime) | |
| 1123 | 626 { |
| 627 /* .elc exists and is out-of-date wrt .el */ | |
| 628 Lisp_Object el_name = make_string (foundstr, foundlen - 1); | |
| 629 struct gcpro nngcpro1; | |
| 630 NNGCPRO1 (el_name); | |
| 631 newer = Ffile_name_nondirectory (el_name); | |
| 632 if (load_ignore_out_of_date_elc_files) | |
| 633 { | |
| 634 int newfd = | |
| 635 locate_file_open_or_access_file | |
| 636 (XSTRING_DATA (el_name), -1); | |
| 637 | |
| 638 if (newfd >= 0) | |
| 639 { | |
| 640 older = Ffile_name_nondirectory (found); | |
| 641 found = el_name; | |
| 642 retry_close (fd); | |
| 643 fd = newfd; | |
| 644 } | |
| 645 } | |
| 646 NNUNGCPRO; | |
| 647 } | |
| 428 | 648 /* put the 'c' back on (kludge-o-rama) */ |
| 649 foundstr[foundlen - 1] = 'c'; | |
| 650 } | |
| 651 } | |
| 652 else if (load_warn_when_source_only && | |
| 653 /* `found' ends in ".el" */ | |
| 654 !memcmp (".el", foundstr + foundlen - 3, 3) && | |
| 655 /* `file' does not end in ".el" */ | |
| 656 memcmp (".el", | |
| 657 XSTRING_DATA (file) + XSTRING_LENGTH (file) - 3, | |
| 658 3)) | |
| 1123 | 659 source_only = 1; |
| 428 | 660 |
| 661 if (!memcmp (".elc", foundstr + foundlen - 4, 4)) | |
| 662 reading_elc = 1; | |
| 663 } | |
| 664 | |
| 1123 | 665 #define PRINT_LOADING_MESSAGE_1(loading, done) \ |
| 666 do { \ | |
| 667 if (load_ignore_elc_files) \ | |
| 668 { \ | |
| 669 if (message_p) \ | |
| 1261 | 670 message (loading done, spaces, \ |
| 1123 | 671 XSTRING_DATA (load_show_full_path_in_messages ? \ |
| 672 found : newer)); \ | |
| 673 } \ | |
| 674 else if (!NILP (older)) \ | |
| 675 { \ | |
| 676 assert (load_ignore_out_of_date_elc_files); \ | |
| 1261 | 677 message (loading done " (file %s is out-of-date)", spaces, \ |
| 1123 | 678 XSTRING_DATA (load_show_full_path_in_messages ? \ |
| 679 found : newer), \ | |
| 680 XSTRING_DATA (older)); \ | |
| 681 } \ | |
| 682 else if (!NILP (newer)) \ | |
| 1261 | 683 message (loading done " (file %s is newer)", spaces, \ |
| 1123 | 684 XSTRING_DATA (load_show_full_path_in_messages ? \ |
| 685 found : file), \ | |
| 686 XSTRING_DATA (newer)); \ | |
| 687 else if (source_only) \ | |
| 1261 | 688 message (loading done " (file %s.elc does not exist)", spaces, \ |
| 1123 | 689 XSTRING_DATA (load_show_full_path_in_messages ? \ |
| 690 found : file), \ | |
| 691 XSTRING_DATA (Ffile_name_nondirectory (file))); \ | |
| 692 else if (message_p) \ | |
| 1261 | 693 message (loading done, spaces, \ |
| 1123 | 694 XSTRING_DATA (load_show_full_path_in_messages ? \ |
| 695 found : file)); \ | |
| 428 | 696 } while (0) |
| 697 | |
| 1261 | 698 #define PRINT_LOADING_MESSAGE(done) \ |
| 699 do { \ | |
| 700 if (from_require) \ | |
| 701 PRINT_LOADING_MESSAGE_1 ("%sRequiring %s...", done); \ | |
| 702 else \ | |
| 703 PRINT_LOADING_MESSAGE_1 ("%sLoading %s...", done); \ | |
| 780 | 704 } while (0) |
| 705 | |
| 428 | 706 PRINT_LOADING_MESSAGE (""); |
| 707 | |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
708 LISP_READONLY (found) = 1; |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
709 |
| 428 | 710 { |
| 711 /* Lisp_Object's must be malloc'ed, not stack-allocated */ | |
| 712 Lisp_Object lispstream = Qnil; | |
| 442 | 713 const int block_size = 8192; |
| 428 | 714 struct gcpro ngcpro1; |
| 715 | |
| 716 NGCPRO1 (lispstream); | |
|
5814
a216b3c2b09e
Add TLS support. See xemacs-patches message with ID
Jerry James <james@xemacs.org>
parents:
5762
diff
changeset
|
717 lispstream = make_filedesc_input_stream (fd, 0, -1, LSTR_CLOSING, NULL); |
| 428 | 718 /* 64K is used for normal files; 8K should be OK here because Lisp |
| 719 files aren't really all that big. */ | |
| 720 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED, | |
| 721 block_size); | |
| 771 | 722 lispstream = make_coding_input_stream |
| 723 (XLSTREAM (lispstream), get_coding_system_for_text_file (codesys, 1), | |
| 800 | 724 CODING_DECODE, 0); |
| 428 | 725 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED, |
| 726 block_size); | |
| 727 /* NOTE: Order of these is very important. Don't rearrange them. */ | |
| 853 | 728 internal_bind_int (&load_in_progress, 1 + load_in_progress); |
| 428 | 729 record_unwind_protect (load_unwind, lispstream); |
| 853 | 730 internal_bind_lisp_object (&Vload_descriptor_list, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
731 Fcons (make_fixnum (fd), Vload_descriptor_list)); |
| 853 | 732 internal_bind_lisp_object (&Vload_file_name_internal, found); |
| 733 /* this is not a simple internal_bind. */ | |
| 428 | 734 record_unwind_protect (load_force_doc_string_unwind, |
| 735 Vload_force_doc_string_list); | |
| 853 | 736 Vload_force_doc_string_list = Qnil; |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
737 /* load-file-name is not read-only to Lisp. */ |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
738 internal_bind_lisp_object (&Vload_file_name, Fcopy_sequence(found)); |
| 428 | 739 #ifdef I18N3 |
| 853 | 740 /* set it to nil; a call to #'domain will set it. */ |
| 741 internal_bind_lisp_object (&Vfile_domain, Qnil); | |
| 428 | 742 #endif |
| 743 | |
|
4448
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
744 /* Is there a #!? If so, read it, and unread ;!. |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
745 |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
746 GNU implement this by treating any #! anywhere in the source text as |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
747 commenting out the whole line. */ |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
748 { |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
749 char shebangp[2]; |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
750 int num_read; |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
751 |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
752 num_read = Lstream_read (XLSTREAM (lispstream), shebangp, |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
753 sizeof(shebangp)); |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
754 if (sizeof(shebangp) == num_read |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
755 && 0 == strncmp("#!", shebangp, sizeof(shebangp))) |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
756 { |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
757 shebangp[0] = ';'; |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
758 } |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
759 |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
760 Lstream_unread (XLSTREAM (lispstream), shebangp, num_read); |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
761 } |
|
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
762 |
| 428 | 763 /* Now determine what sort of ELC file we're reading in. */ |
| 853 | 764 internal_bind_int (&load_byte_code_version, load_byte_code_version); |
| 428 | 765 if (reading_elc) |
| 766 { | |
| 767 char elc_header[8]; | |
| 768 int num_read; | |
| 769 | |
| 770 num_read = Lstream_read (XLSTREAM (lispstream), elc_header, 8); | |
| 771 if (num_read < 8 | |
| 772 || strncmp (elc_header, ";ELC", 4)) | |
| 773 { | |
| 774 /* Huh? Probably not a valid ELC file. */ | |
| 775 load_byte_code_version = 100; /* no Ebolification needed */ | |
| 776 Lstream_unread (XLSTREAM (lispstream), elc_header, num_read); | |
| 777 } | |
| 778 else | |
| 779 load_byte_code_version = elc_header[4]; | |
| 780 } | |
| 781 else | |
| 782 load_byte_code_version = 100; /* no Ebolification needed */ | |
| 783 | |
| 784 readevalloop (lispstream, file, Feval, 0); | |
| 785 if (!NILP (used_codesys)) | |
| 786 Fset (used_codesys, | |
| 787 XCODING_SYSTEM_NAME | |
| 771 | 788 (coding_stream_detected_coding_system (XLSTREAM (lispstream)))); |
| 789 unbind_to (speccount); | |
| 428 | 790 |
| 791 NUNGCPRO; | |
| 792 } | |
| 793 | |
| 794 { | |
| 795 Lisp_Object tem; | |
| 796 /* #### Disgusting kludge */ | |
| 797 /* Run any load-hooks for this file. */ | |
| 798 /* #### An even more disgusting kludge. There is horrible code */ | |
| 799 /* that is relying on the fact that dumped lisp files are found */ | |
| 800 /* via `load-path' search. */ | |
| 801 Lisp_Object name = file; | |
| 802 | |
| 1123 | 803 if (!NILP (Ffile_name_absolute_p (file))) |
| 804 name = Ffile_name_nondirectory (file); | |
| 428 | 805 |
| 1261 | 806 tem = Fassoc (name, Vafter_load_alist); |
| 428 | 807 if (!NILP (tem)) |
| 808 { | |
| 809 struct gcpro ngcpro1; | |
| 810 | |
| 811 NGCPRO1 (tem); | |
| 812 /* Use eval so that errors give a semi-meaningful backtrace. --Stig */ | |
| 813 tem = Fcons (Qprogn, Fcdr (tem)); | |
| 814 Feval (tem); | |
| 815 NUNGCPRO; | |
| 816 } | |
| 817 } | |
| 818 | |
| 819 if (!noninteractive) | |
| 820 PRINT_LOADING_MESSAGE ("done"); | |
| 821 | |
| 1292 | 822 retval = Qt; |
| 823 done: | |
| 824 PROFILE_RECORD_EXITING_SECTION (Qload_internal); | |
| 428 | 825 UNGCPRO; |
| 1292 | 826 return retval; |
| 428 | 827 } |
| 828 | |
| 829 | |
| 830 /* ------------------------------- */ | |
| 831 /* locate_file */ | |
| 832 /* ------------------------------- */ | |
| 833 | |
| 834 static int | |
| 835 decode_mode_1 (Lisp_Object mode) | |
| 836 { | |
| 837 if (EQ (mode, Qexists)) | |
| 838 return F_OK; | |
| 839 else if (EQ (mode, Qexecutable)) | |
| 840 return X_OK; | |
| 841 else if (EQ (mode, Qwritable)) | |
| 842 return W_OK; | |
| 843 else if (EQ (mode, Qreadable)) | |
| 844 return R_OK; | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5247
diff
changeset
|
845 else if (INTEGERP (mode)) |
| 428 | 846 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
847 check_integer_range (mode, Qzero, make_fixnum (7)); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
848 return XFIXNUM (mode); |
| 428 | 849 } |
| 850 else | |
| 563 | 851 invalid_argument ("Invalid value", mode); |
| 428 | 852 return 0; /* unreached */ |
| 853 } | |
| 854 | |
| 855 static int | |
| 856 decode_mode (Lisp_Object mode) | |
| 857 { | |
| 858 if (NILP (mode)) | |
| 859 return R_OK; | |
| 860 else if (CONSP (mode)) | |
| 861 { | |
| 862 int mask = 0; | |
| 2367 | 863 EXTERNAL_LIST_LOOP_2 (elt, mode) |
| 864 mask |= decode_mode_1 (elt); | |
| 428 | 865 return mask; |
| 866 } | |
| 867 else | |
| 868 return decode_mode_1 (mode); | |
| 869 } | |
| 870 | |
| 871 DEFUN ("locate-file", Flocate_file, 2, 4, 0, /* | |
| 872 Search for FILENAME through PATH-LIST. | |
| 873 | |
| 874 If SUFFIXES is non-nil, it should be a list of suffixes to append to | |
| 875 file name when searching. | |
| 876 | |
| 877 If MODE is non-nil, it should be a symbol or a list of symbol representing | |
| 878 requirements. Allowed symbols are `exists', `executable', `writable', and | |
| 879 `readable'. If MODE is nil, it defaults to `readable'. | |
| 880 | |
| 2548 | 881 Filenames are checked against `load-suppress-alist' to determine if they |
| 882 should be ignored. | |
| 883 | |
| 428 | 884 `locate-file' keeps hash tables of the directories it searches through, |
| 885 in order to speed things up. It tries valiantly to not get confused in | |
| 886 the face of a changing and unpredictable environment, but can occasionally | |
| 887 get tripped up. In this case, you will have to call | |
| 888 `locate-file-clear-hashing' to get it back on track. See that function | |
| 889 for details. | |
| 890 */ | |
| 891 (filename, path_list, suffixes, mode)) | |
| 892 { | |
| 893 /* This function can GC */ | |
| 894 Lisp_Object tp; | |
| 895 | |
| 896 CHECK_STRING (filename); | |
| 897 | |
| 898 if (LISTP (suffixes)) | |
| 899 { | |
| 2367 | 900 EXTERNAL_LIST_LOOP_2 (elt, suffixes) |
| 901 CHECK_STRING (elt); | |
| 428 | 902 } |
| 903 else | |
| 904 CHECK_STRING (suffixes); | |
| 905 | |
| 906 locate_file (path_list, filename, suffixes, &tp, decode_mode (mode)); | |
| 907 return tp; | |
| 908 } | |
| 909 | |
| 910 /* Recalculate the hash table for the given string. DIRECTORY should | |
| 911 better have been through Fexpand_file_name() by now. */ | |
| 912 | |
| 913 static Lisp_Object | |
| 914 locate_file_refresh_hashing (Lisp_Object directory) | |
| 915 { | |
|
5211
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
916 Lisp_Object hash = make_directory_hash_table (directory); |
| 428 | 917 |
| 918 if (!NILP (hash)) | |
| 919 Fputhash (directory, hash, Vlocate_file_hash_table); | |
| 920 return hash; | |
| 921 } | |
| 922 | |
| 923 /* find the hash table for the given directory, recalculating if necessary */ | |
| 924 | |
| 925 static Lisp_Object | |
| 926 locate_file_find_directory_hash_table (Lisp_Object directory) | |
| 927 { | |
| 928 Lisp_Object hash = Fgethash (directory, Vlocate_file_hash_table, Qnil); | |
| 929 if (NILP (hash)) | |
| 930 return locate_file_refresh_hashing (directory); | |
| 931 else | |
| 932 return hash; | |
| 933 } | |
| 934 | |
| 935 /* The SUFFIXES argument in any of the locate_file* functions can be | |
| 936 nil, a list, or a string (for backward compatibility), with the | |
| 937 following semantics: | |
| 938 | |
| 939 a) nil - no suffix, just search for file name intact | |
| 940 (semantically different from "empty suffix list", which | |
| 941 would be meaningless.) | |
| 942 b) list - list of suffixes to append to file name. Each of these | |
| 943 must be a string. | |
| 944 c) string - colon-separated suffixes to append to file name (backward | |
| 945 compatibility). | |
| 946 | |
| 947 All of this got hairy, so I decided to use a mapper. Calling a | |
| 948 function for each suffix shouldn't slow things down, since | |
| 949 locate_file is rarely called with enough suffixes for funcalls to | |
| 950 make any difference. */ | |
| 951 | |
| 952 /* Map FUN over SUFFIXES, as described above. FUN will be called with a | |
| 953 char * containing the current file name, and ARG. Mapping stops when | |
| 954 FUN returns non-zero. */ | |
| 955 static void | |
| 956 locate_file_map_suffixes (Lisp_Object filename, Lisp_Object suffixes, | |
| 867 | 957 int (*fun) (Ibyte *, void *), |
| 428 | 958 void *arg) |
| 959 { | |
| 960 /* This function can GC */ | |
| 867 | 961 Ibyte *fn; |
| 428 | 962 int fn_len, max; |
| 963 | |
| 964 /* Calculate maximum size of any filename made from | |
| 965 this path element/specified file name and any possible suffix. */ | |
| 966 if (CONSP (suffixes)) | |
| 967 { | |
| 968 /* We must traverse the list, so why not do it right. */ | |
| 969 Lisp_Object tail; | |
| 970 max = 0; | |
| 971 LIST_LOOP (tail, suffixes) | |
| 972 { | |
| 973 if (XSTRING_LENGTH (XCAR (tail)) > max) | |
| 974 max = XSTRING_LENGTH (XCAR (tail)); | |
| 975 } | |
| 976 } | |
| 977 else if (NILP (suffixes)) | |
| 978 max = 0; | |
| 979 else | |
| 980 /* Just take the easy way out */ | |
| 981 max = XSTRING_LENGTH (suffixes); | |
| 982 | |
| 983 fn_len = XSTRING_LENGTH (filename); | |
| 2367 | 984 fn = alloca_ibytes (max + fn_len + 1); |
| 771 | 985 memcpy (fn, XSTRING_DATA (filename), fn_len); |
| 428 | 986 |
| 987 /* Loop over suffixes. */ | |
| 988 if (!STRINGP (suffixes)) | |
| 989 { | |
| 990 if (NILP (suffixes)) | |
| 991 { | |
| 992 /* Case a) discussed in the comment above. */ | |
| 993 fn[fn_len] = 0; | |
| 994 if ((*fun) (fn, arg)) | |
| 995 return; | |
| 996 } | |
| 997 else | |
| 998 { | |
| 999 /* Case b) */ | |
| 1000 Lisp_Object tail; | |
| 1001 LIST_LOOP (tail, suffixes) | |
| 1002 { | |
| 1003 memcpy (fn + fn_len, XSTRING_DATA (XCAR (tail)), | |
| 1004 XSTRING_LENGTH (XCAR (tail))); | |
| 1005 fn[fn_len + XSTRING_LENGTH (XCAR (tail))] = 0; | |
| 1006 if ((*fun) (fn, arg)) | |
| 1007 return; | |
| 1008 } | |
| 1009 } | |
| 1010 } | |
| 1011 else | |
| 1012 { | |
| 1013 /* Case c) */ | |
| 867 | 1014 const Ibyte *nsuffix = XSTRING_DATA (suffixes); |
| 428 | 1015 |
| 1016 while (1) | |
| 1017 { | |
| 867 | 1018 Ibyte *esuffix = qxestrchr (nsuffix, ':'); |
| 771 | 1019 Bytecount lsuffix = esuffix ? esuffix - nsuffix : |
| 1020 qxestrlen (nsuffix); | |
| 428 | 1021 |
| 1022 /* Concatenate path element/specified name with the suffix. */ | |
| 771 | 1023 qxestrncpy (fn + fn_len, nsuffix, lsuffix); |
| 428 | 1024 fn[fn_len + lsuffix] = 0; |
| 1025 | |
| 1026 if ((*fun) (fn, arg)) | |
| 1027 return; | |
| 1028 | |
| 1029 /* Advance to next suffix. */ | |
| 1030 if (esuffix == 0) | |
| 1031 break; | |
| 1032 nsuffix += lsuffix + 1; | |
| 1033 } | |
| 1034 } | |
| 1035 } | |
| 1036 | |
| 771 | 1037 struct locate_file_in_directory_mapper_closure |
| 1038 { | |
| 428 | 1039 int fd; |
| 1040 Lisp_Object *storeptr; | |
| 1041 int mode; | |
| 1042 }; | |
| 1043 | |
| 1123 | 1044 /* open() or access() a file to be returned by locate_file(). if |
| 1045 ACCESS_MODE >= 0, do an access() with that mode, else open(). Does | |
| 1046 various magic, e.g. opening the file read-only and binary and setting | |
| 1047 the close-on-exec flag on the file. */ | |
| 1048 | |
| 1049 static int | |
| 1050 locate_file_open_or_access_file (Ibyte *fn, int access_mode) | |
| 1051 { | |
| 1052 int val; | |
| 1053 | |
| 1054 /* Check that we can access or open it. */ | |
| 1055 if (access_mode >= 0) | |
| 1056 val = qxe_access (fn, access_mode); | |
| 1057 else | |
| 1058 { | |
| 1059 val = qxe_open (fn, O_RDONLY | OPEN_BINARY, 0); | |
| 1060 | |
| 1061 #ifndef WIN32_NATIVE | |
| 1062 if (val >= 0) | |
| 1063 /* If we actually opened the file, set close-on-exec flag | |
| 1064 on the new descriptor so that subprocesses can't whack | |
| 1065 at it. */ | |
| 1066 (void) fcntl (val, F_SETFD, FD_CLOEXEC); | |
| 1067 #endif | |
| 1068 } | |
| 1069 | |
| 1070 return val; | |
| 1071 } | |
| 1072 | |
| 428 | 1073 static int |
| 867 | 1074 locate_file_in_directory_mapper (Ibyte *fn, void *arg) |
| 428 | 1075 { |
| 1076 struct locate_file_in_directory_mapper_closure *closure = | |
| 771 | 1077 (struct locate_file_in_directory_mapper_closure *) arg; |
| 428 | 1078 struct stat st; |
| 1079 | |
| 1080 /* Ignore file if it's a directory. */ | |
| 771 | 1081 if (qxe_stat (fn, &st) >= 0 |
| 428 | 1082 && (st.st_mode & S_IFMT) != S_IFDIR) |
| 1083 { | |
| 1084 /* Check that we can access or open it. */ | |
| 1123 | 1085 closure->fd = locate_file_open_or_access_file (fn, closure->mode); |
| 428 | 1086 |
| 1087 if (closure->fd >= 0) | |
| 1088 { | |
| 2548 | 1089 if (!check_if_suppressed (fn, Qnil)) |
| 1090 { | |
| 1091 /* We succeeded; return this descriptor and filename. */ | |
| 1092 if (closure->storeptr) | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1093 *closure->storeptr = build_istring (fn); |
| 2548 | 1094 |
| 1095 return 1; | |
| 1096 } | |
| 428 | 1097 } |
| 1098 } | |
| 1099 /* Keep mapping. */ | |
| 1100 return 0; | |
| 1101 } | |
| 1102 | |
| 1103 | |
| 1104 /* look for STR in PATH, optionally adding SUFFIXES. DIRECTORY need | |
| 1105 not have been expanded. */ | |
| 1106 | |
| 1107 static int | |
| 1108 locate_file_in_directory (Lisp_Object directory, Lisp_Object str, | |
| 1109 Lisp_Object suffixes, Lisp_Object *storeptr, | |
| 1110 int mode) | |
| 1111 { | |
| 1112 /* This function can GC */ | |
| 1113 struct locate_file_in_directory_mapper_closure closure; | |
| 1114 Lisp_Object filename = Qnil; | |
| 1115 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 1116 | |
| 1117 GCPRO3 (directory, str, filename); | |
| 1118 | |
| 1119 filename = Fexpand_file_name (str, directory); | |
| 1120 if (NILP (filename) || NILP (Ffile_name_absolute_p (filename))) | |
| 1121 /* If there are non-absolute elts in PATH (eg ".") */ | |
| 1122 /* Of course, this could conceivably lose if luser sets | |
| 1123 default-directory to be something non-absolute ... */ | |
| 1124 { | |
| 1125 if (NILP (filename)) | |
| 1126 /* NIL means current directory */ | |
| 1127 filename = current_buffer->directory; | |
| 1128 else | |
| 1129 filename = Fexpand_file_name (filename, | |
| 1130 current_buffer->directory); | |
| 1131 if (NILP (Ffile_name_absolute_p (filename))) | |
| 1132 { | |
| 1133 /* Give up on this directory! */ | |
| 1134 UNGCPRO; | |
| 1135 return -1; | |
| 1136 } | |
| 1137 } | |
| 1138 | |
| 1139 closure.fd = -1; | |
| 1140 closure.storeptr = storeptr; | |
| 1141 closure.mode = mode; | |
| 1142 | |
| 771 | 1143 locate_file_map_suffixes (filename, suffixes, |
| 1144 locate_file_in_directory_mapper, | |
| 428 | 1145 &closure); |
| 1146 | |
| 1147 UNGCPRO; | |
| 1148 return closure.fd; | |
| 1149 } | |
| 1150 | |
| 1151 /* do the same as locate_file() but don't use any hash tables. */ | |
| 1152 | |
| 1153 static int | |
| 1154 locate_file_without_hash (Lisp_Object path, Lisp_Object str, | |
| 1155 Lisp_Object suffixes, Lisp_Object *storeptr, | |
| 1156 int mode) | |
| 1157 { | |
| 1158 /* This function can GC */ | |
| 1159 int absolute = !NILP (Ffile_name_absolute_p (str)); | |
| 1160 | |
| 2367 | 1161 EXTERNAL_LIST_LOOP_2 (elt, path) |
| 428 | 1162 { |
| 2367 | 1163 int val = locate_file_in_directory (elt, str, suffixes, storeptr, |
| 428 | 1164 mode); |
| 1165 if (val >= 0) | |
| 1166 return val; | |
| 1167 if (absolute) | |
| 1168 break; | |
| 1169 } | |
| 1170 return -1; | |
| 1171 } | |
| 1172 | |
| 1173 static int | |
| 867 | 1174 locate_file_construct_suffixed_files_mapper (Ibyte *fn, void *arg) |
| 428 | 1175 { |
| 771 | 1176 Lisp_Object *tail = (Lisp_Object *) arg; |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1177 *tail = Fcons (build_istring (fn), *tail); |
| 428 | 1178 return 0; |
| 1179 } | |
| 1180 | |
| 1181 /* Construct a list of all files to search for. | |
| 1182 It makes sense to have this despite locate_file_map_suffixes() | |
| 1183 because we need Lisp strings to access the hash-table, and it would | |
| 1184 be inefficient to create them on the fly, again and again for each | |
| 1185 path component. See locate_file(). */ | |
| 1186 | |
| 1187 static Lisp_Object | |
| 1188 locate_file_construct_suffixed_files (Lisp_Object filename, | |
| 1189 Lisp_Object suffixes) | |
| 1190 { | |
| 1191 Lisp_Object tail = Qnil; | |
| 1192 struct gcpro gcpro1; | |
| 1193 GCPRO1 (tail); | |
| 1194 | |
| 1195 locate_file_map_suffixes (filename, suffixes, | |
| 1196 locate_file_construct_suffixed_files_mapper, | |
| 1197 &tail); | |
| 1198 | |
| 1199 UNGCPRO; | |
| 1200 return Fnreverse (tail); | |
| 1201 } | |
| 1202 | |
| 1203 DEFUN ("locate-file-clear-hashing", Flocate_file_clear_hashing, 1, 1, 0, /* | |
| 1204 Clear the hash records for the specified list of directories. | |
| 1205 `locate-file' uses a hashing scheme to speed lookup, and will correctly | |
| 1206 track the following environmental changes: | |
| 1207 | |
| 1208 -- changes of any sort to the list of directories to be searched. | |
| 1209 -- addition and deletion of non-shadowing files (see below) from the | |
| 1210 directories in the list. | |
| 1211 -- byte-compilation of a .el file into a .elc file. | |
| 1212 | |
| 1213 `locate-file' will primarily get confused if you add a file that shadows | |
| 1214 \(i.e. has the same name as) another file further down in the directory list. | |
| 1215 In this case, you must call `locate-file-clear-hashing'. | |
| 1216 | |
| 1217 If PATH is t, it means to fully clear all the accumulated hashes. This | |
| 1218 can be used if the internal tables grow too large, or when dumping. | |
| 1219 */ | |
| 1220 (path)) | |
| 1221 { | |
| 1222 if (EQ (path, Qt)) | |
| 1223 Fclrhash (Vlocate_file_hash_table); | |
| 1224 else | |
| 1225 { | |
| 2367 | 1226 EXTERNAL_LIST_LOOP_2 (elt, path) |
| 428 | 1227 { |
| 2367 | 1228 Lisp_Object pathel = Fexpand_file_name (elt, Qnil); |
| 428 | 1229 Fremhash (pathel, Vlocate_file_hash_table); |
| 1230 } | |
| 1231 } | |
| 1232 return Qnil; | |
| 1233 } | |
| 1234 | |
| 1235 /* Search for a file whose name is STR, looking in directories | |
| 1236 in the Lisp list PATH, and trying suffixes from SUFFIXES. | |
| 1237 SUFFIXES is a list of possible suffixes, or (for backward | |
| 1238 compatibility) a string containing possible suffixes separated by | |
| 1239 colons. | |
| 1240 On success, returns a file descriptor. On failure, returns -1. | |
| 1241 | |
| 1242 MODE nonnegative means don't open the files, | |
| 1243 just look for one for which access(file,MODE) succeeds. In this case, | |
| 951 | 1244 returns a nonnegative value on success. On failure, returns -1. |
| 428 | 1245 |
| 2548 | 1246 If STOREPTR is non-nil, it points to a slot where the name of |
| 428 | 1247 the file actually found should be stored as a Lisp string. |
| 1248 Nil is stored there on failure. | |
| 1249 | |
| 1250 Called openp() in FSFmacs. */ | |
| 1251 | |
| 1252 int | |
| 1253 locate_file (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, | |
| 1254 Lisp_Object *storeptr, int mode) | |
| 1255 { | |
| 1256 /* This function can GC */ | |
| 1257 Lisp_Object suffixtab = Qnil; | |
| 2367 | 1258 Lisp_Object pathel_expanded; |
| 428 | 1259 int val; |
| 1260 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1261 | |
| 1262 if (storeptr) | |
| 1263 *storeptr = Qnil; | |
| 1264 | |
| 1265 /* Is it really necessary to gcpro path and str? It shouldn't be | |
| 1266 unless some caller has fucked up. There are known instances that | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
1267 call us with build_ascstring("foo:bar") as SUFFIXES, though. */ |
| 428 | 1268 GCPRO4 (path, str, suffixes, suffixtab); |
| 1269 | |
| 1270 /* if this filename has directory components, it's too complicated | |
| 1271 to try and use the hash tables. */ | |
| 1272 if (!NILP (Ffile_name_directory (str))) | |
| 1273 { | |
| 1274 val = locate_file_without_hash (path, str, suffixes, storeptr, mode); | |
| 1275 UNGCPRO; | |
| 1276 return val; | |
| 1277 } | |
| 1278 | |
| 1279 suffixtab = locate_file_construct_suffixed_files (str, suffixes); | |
| 1280 | |
| 2367 | 1281 { |
| 1282 EXTERNAL_LIST_LOOP_2 (pathel, path) | |
| 1283 { | |
| 1284 Lisp_Object hash_table; | |
| 1285 int found = 0; | |
| 1286 | |
| 1287 /* If this path element is relative, we have to look by hand. */ | |
| 1288 if (NILP (pathel) || NILP (Ffile_name_absolute_p (pathel))) | |
| 1289 { | |
| 1290 val = locate_file_in_directory (pathel, str, suffixes, storeptr, | |
| 1291 mode); | |
| 1292 if (val >= 0) | |
| 428 | 1293 { |
| 2367 | 1294 UNGCPRO; |
| 1295 return val; | |
| 428 | 1296 } |
| 2367 | 1297 continue; |
| 1298 } | |
| 1299 | |
| 1300 pathel_expanded = Fexpand_file_name (pathel, Qnil); | |
| 1301 hash_table = locate_file_find_directory_hash_table (pathel_expanded); | |
| 1302 | |
| 1303 if (!NILP (hash_table)) | |
| 1304 { | |
| 1305 /* Loop over suffixes. */ | |
| 1306 LIST_LOOP_2 (elt, suffixtab) | |
| 1307 if (!NILP (Fgethash (elt, hash_table, Qnil))) | |
| 1308 { | |
| 1309 found = 1; | |
| 1310 break; | |
| 1311 } | |
| 1312 } | |
| 1313 | |
| 1314 if (found) | |
| 1315 { | |
| 1316 /* This is a likely candidate. Look by hand in this directory | |
| 1317 so we don't get thrown off if someone byte-compiles a file. */ | |
| 1318 val = locate_file_in_directory (pathel, str, suffixes, storeptr, | |
| 1319 mode); | |
| 1320 if (val >= 0) | |
| 1321 { | |
| 1322 UNGCPRO; | |
| 1323 return val; | |
| 1324 } | |
| 1325 | |
| 1326 /* Hmm ... the file isn't actually there. (Or possibly it's | |
| 1327 a directory ...) So refresh our hashing. */ | |
| 1328 locate_file_refresh_hashing (pathel_expanded); | |
| 1329 } | |
| 1330 } | |
| 428 | 1331 } |
| 1332 | |
| 1333 /* File is probably not there, but check the hard way just in case. */ | |
| 1334 val = locate_file_without_hash (path, str, suffixes, storeptr, mode); | |
| 1335 if (val >= 0) | |
| 1336 { | |
| 1337 /* Sneaky user added a file without telling us. */ | |
| 1338 Flocate_file_clear_hashing (path); | |
| 1339 } | |
| 1340 | |
| 1341 UNGCPRO; | |
| 1342 return val; | |
| 1343 } | |
| 1344 | |
| 1345 | |
| 1346 #ifdef LOADHIST | |
| 1347 | |
| 1348 /* Merge the list we've accumulated of globals from the current input source | |
| 1349 into the load_history variable. The details depend on whether | |
| 1350 the source has an associated file name or not. */ | |
| 1351 | |
| 1352 static void | |
| 1353 build_load_history (int loading, Lisp_Object source) | |
| 1354 { | |
| 1355 REGISTER Lisp_Object tail, prev, newelt; | |
| 1356 REGISTER Lisp_Object tem, tem2; | |
| 1357 int foundit; | |
| 1358 | |
| 1359 #if !defined(LOADHIST_DUMPED) | |
| 1360 /* Don't bother recording anything for preloaded files. */ | |
| 1361 if (purify_flag) | |
| 1362 return; | |
| 1363 #endif | |
| 1364 | |
| 1365 tail = Vload_history; | |
| 1366 prev = Qnil; | |
| 1367 foundit = 0; | |
| 1368 while (!NILP (tail)) | |
| 1369 { | |
| 1370 tem = Fcar (tail); | |
| 1371 | |
| 1372 /* Find the feature's previous assoc list... */ | |
| 1373 if (internal_equal (source, Fcar (tem), 0)) | |
| 1374 { | |
| 1375 foundit = 1; | |
| 1376 | |
| 1377 /* If we're loading, remove it. */ | |
| 1378 if (loading) | |
| 1379 { | |
| 1380 if (NILP (prev)) | |
| 1381 Vload_history = Fcdr (tail); | |
| 1382 else | |
| 1383 Fsetcdr (prev, Fcdr (tail)); | |
| 1384 } | |
| 1385 | |
| 1386 /* Otherwise, cons on new symbols that are not already members. */ | |
| 1387 else | |
| 1388 { | |
| 1389 tem2 = Vcurrent_load_list; | |
| 1390 | |
| 1391 while (CONSP (tem2)) | |
| 1392 { | |
| 1393 newelt = XCAR (tem2); | |
| 1394 | |
| 1395 if (NILP (Fmemq (newelt, tem))) | |
| 1396 Fsetcar (tail, Fcons (Fcar (tem), | |
| 1397 Fcons (newelt, Fcdr (tem)))); | |
| 1398 | |
| 1399 tem2 = XCDR (tem2); | |
| 1400 QUIT; | |
| 1401 } | |
| 1402 } | |
| 1403 } | |
| 1404 else | |
| 1405 prev = tail; | |
| 1406 tail = Fcdr (tail); | |
| 1407 QUIT; | |
| 1408 } | |
| 1409 | |
| 1410 /* If we're loading, cons the new assoc onto the front of load-history, | |
| 1411 the most-recently-loaded position. Also do this if we didn't find | |
| 1412 an existing member for the current source. */ | |
| 1413 if (loading || !foundit) | |
| 1414 Vload_history = Fcons (Fnreverse (Vcurrent_load_list), | |
| 1415 Vload_history); | |
| 1416 } | |
| 1417 | |
| 1418 #else /* !LOADHIST */ | |
| 1419 #define build_load_history(x,y) | |
| 1420 #endif /* !LOADHIST */ | |
| 1421 | |
| 1422 | |
| 1423 static void | |
| 1424 readevalloop (Lisp_Object readcharfun, | |
| 1425 Lisp_Object sourcename, | |
| 1426 Lisp_Object (*evalfun) (Lisp_Object), | |
| 1427 int printflag) | |
| 1428 { | |
| 1429 /* This function can GC */ | |
| 867 | 1430 REGISTER Ichar c; |
| 1849 | 1431 Lisp_Object val = Qnil; |
| 428 | 1432 int speccount = specpdl_depth (); |
| 1433 struct gcpro gcpro1, gcpro2; | |
| 1434 struct buffer *b = 0; | |
| 1435 | |
| 1436 if (BUFFERP (readcharfun)) | |
| 1437 b = XBUFFER (readcharfun); | |
| 1438 else if (MARKERP (readcharfun)) | |
| 1439 b = XMARKER (readcharfun)->buffer; | |
| 1440 | |
| 1441 /* Don't do this. It is not necessary, and it needlessly exposes | |
| 1442 READCHARFUN (which can be a stream) to Lisp. --hniksic */ | |
| 1443 /*specbind (Qstandard_input, readcharfun);*/ | |
| 1444 | |
| 2548 | 1445 internal_bind_lisp_object (&Vcurrent_load_list, Qnil); |
| 428 | 1446 |
| 1447 GCPRO2 (val, sourcename); | |
| 1448 | |
| 1449 LOADHIST_ATTACH (sourcename); | |
| 1450 | |
| 1451 while (1) | |
| 1452 { | |
| 1453 QUIT; | |
| 1454 | |
| 1455 if (b != 0 && !BUFFER_LIVE_P (b)) | |
| 563 | 1456 invalid_operation ("Reading from killed buffer", Qunbound); |
| 428 | 1457 |
| 1458 c = readchar (readcharfun); | |
| 1459 if (c == ';') | |
| 1460 { | |
| 1461 /* Skip comment */ | |
| 1462 while ((c = readchar (readcharfun)) != '\n' && c != -1) | |
| 1463 QUIT; | |
| 1464 continue; | |
| 1465 } | |
| 1466 if (c < 0) | |
| 1467 break; | |
| 1468 | |
| 1469 /* Ignore whitespace here, so we can detect eof. */ | |
| 1470 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r') | |
| 1471 continue; | |
| 1472 | |
| 814 | 1473 unreadchar (readcharfun, c); |
| 1474 Vread_objects = Qnil; | |
| 1475 if (NILP (Vload_read_function)) | |
| 1476 val = read0 (readcharfun); | |
| 428 | 1477 else |
| 814 | 1478 val = call1 (Vload_read_function, readcharfun); |
| 428 | 1479 val = (*evalfun) (val); |
| 1480 if (printflag) | |
| 1481 { | |
| 1482 Vvalues = Fcons (val, Vvalues); | |
| 1483 if (EQ (Vstandard_output, Qt)) | |
| 1484 Fprin1 (val, Qnil); | |
| 1485 else | |
| 1486 Fprint (val, Qnil); | |
| 1487 } | |
| 1488 } | |
| 1489 | |
| 1490 build_load_history (LSTREAMP (readcharfun) || | |
| 1491 /* This looks weird, but it's what's in FSFmacs */ | |
| 1492 (b ? BUF_NARROWED (b) : BUF_NARROWED (current_buffer)), | |
| 1493 sourcename); | |
| 1494 UNGCPRO; | |
| 1495 | |
| 771 | 1496 unbind_to (speccount); |
| 428 | 1497 } |
| 1498 | |
| 1499 DEFUN ("eval-buffer", Feval_buffer, 0, 2, "bBuffer: ", /* | |
| 1500 Execute BUFFER as Lisp code. | |
| 1501 Programs can pass two arguments, BUFFER and PRINTFLAG. | |
| 1502 BUFFER is the buffer to evaluate (nil means use current buffer). | |
| 1503 PRINTFLAG controls printing of output: | |
| 444 | 1504 nil means discard it; anything else is a stream for printing. |
| 428 | 1505 |
| 1506 If there is no error, point does not move. If there is an error, | |
| 1507 point remains at the end of the last character read from the buffer. | |
| 1508 */ | |
| 444 | 1509 (buffer, printflag)) |
| 428 | 1510 { |
| 1511 /* This function can GC */ | |
| 1512 int speccount = specpdl_depth (); | |
| 1513 Lisp_Object tem, buf; | |
| 1514 | |
| 444 | 1515 if (NILP (buffer)) |
| 428 | 1516 buf = Fcurrent_buffer (); |
| 1517 else | |
| 444 | 1518 buf = Fget_buffer (buffer); |
| 428 | 1519 if (NILP (buf)) |
| 563 | 1520 invalid_argument ("No such buffer", Qunbound); |
| 428 | 1521 |
| 1522 if (NILP (printflag)) | |
| 1523 tem = Qsymbolp; /* #### #@[]*&$#*[& SI:NULL-STREAM */ | |
| 1524 else | |
| 1525 tem = printflag; | |
| 1526 specbind (Qstandard_output, tem); | |
| 1527 record_unwind_protect (save_excursion_restore, save_excursion_save ()); | |
| 1528 BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); | |
| 1529 readevalloop (buf, XBUFFER (buf)->filename, Feval, | |
| 1530 !NILP (printflag)); | |
| 1531 | |
| 771 | 1532 return unbind_to (speccount); |
| 428 | 1533 } |
| 1534 | |
| 1535 #if 0 | |
| 826 | 1536 DEFUN ("eval-current-buffer", Feval_current_buffer, 0, 1, "", /* |
| 428 | 1537 Execute the current buffer as Lisp code. |
| 1538 Programs can pass argument PRINTFLAG which controls printing of output: | |
| 1539 nil means discard it; anything else is stream for print. | |
| 1540 | |
| 1541 If there is no error, point does not move. If there is an error, | |
| 1542 point remains at the end of the last character read from the buffer. | |
| 1543 */ | |
| 1544 (printflag)) | |
| 1545 { | |
| 1546 code omitted; | |
| 1547 } | |
| 1548 #endif /* 0 */ | |
| 1549 | |
| 1550 DEFUN ("eval-region", Feval_region, 2, 3, "r", /* | |
| 1551 Execute the region as Lisp code. | |
| 444 | 1552 When called from programs, expects two arguments START and END |
| 428 | 1553 giving starting and ending indices in the current buffer |
| 1554 of the text to be executed. | |
| 444 | 1555 Programs can pass third optional argument STREAM which controls output: |
| 428 | 1556 nil means discard it; anything else is stream for printing it. |
| 1557 | |
| 1558 If there is no error, point does not move. If there is an error, | |
| 1559 point remains at the end of the last character read from the buffer. | |
| 1560 | |
| 1561 Note: Before evaling the region, this function narrows the buffer to it. | |
| 1562 If the code being eval'd should happen to trigger a redisplay you may | |
| 1563 see some text temporarily disappear because of this. | |
| 1564 */ | |
| 444 | 1565 (start, end, stream)) |
| 428 | 1566 { |
| 1567 /* This function can GC */ | |
| 1568 int speccount = specpdl_depth (); | |
| 1569 Lisp_Object tem; | |
| 1570 Lisp_Object cbuf = Fcurrent_buffer (); | |
| 1571 | |
| 444 | 1572 if (NILP (stream)) |
| 428 | 1573 tem = Qsymbolp; /* #### #@[]*&$#*[& SI:NULL-STREAM */ |
| 1574 else | |
| 444 | 1575 tem = stream; |
| 428 | 1576 specbind (Qstandard_output, tem); |
| 1577 | |
| 444 | 1578 if (NILP (stream)) |
| 428 | 1579 record_unwind_protect (save_excursion_restore, save_excursion_save ()); |
| 844 | 1580 record_unwind_protect (save_restriction_restore, |
| 1581 save_restriction_save (current_buffer)); | |
| 428 | 1582 |
| 444 | 1583 /* This both uses start and checks its type. */ |
| 1584 Fgoto_char (start, cbuf); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1585 Fnarrow_to_region (make_fixnum (BUF_BEGV (current_buffer)), end, cbuf); |
| 428 | 1586 readevalloop (cbuf, XBUFFER (cbuf)->filename, Feval, |
| 444 | 1587 !NILP (stream)); |
| 428 | 1588 |
| 771 | 1589 return unbind_to (speccount); |
| 428 | 1590 } |
| 1591 | |
| 1592 DEFUN ("read", Fread, 0, 1, 0, /* | |
| 1593 Read one Lisp expression as text from STREAM, return as Lisp object. | |
| 1594 If STREAM is nil, use the value of `standard-input' (which see). | |
| 1595 STREAM or the value of `standard-input' may be: | |
| 1596 a buffer (read from point and advance it) | |
| 1597 a marker (read from where it points and advance it) | |
| 1598 a function (call it with no arguments for each character, | |
| 1599 call it with a char as argument to push a char back) | |
| 1600 a string (takes text from string, starting at the beginning) | |
| 1601 t (read text line using minibuffer and use it). | |
| 1602 */ | |
| 1603 (stream)) | |
| 1604 { | |
| 1605 if (NILP (stream)) | |
| 1606 stream = Vstandard_input; | |
| 1607 if (EQ (stream, Qt)) | |
| 1608 stream = Qread_char; | |
| 1609 | |
| 1610 Vread_objects = Qnil; | |
| 1611 | |
| 1612 if (EQ (stream, Qread_char)) | |
| 1613 { | |
| 1614 Lisp_Object val = call1 (Qread_from_minibuffer, | |
| 771 | 1615 build_msg_string ("Lisp expression: ")); |
| 428 | 1616 return Fcar (Fread_from_string (val, Qnil, Qnil)); |
| 1617 } | |
| 1618 | |
| 1619 if (STRINGP (stream)) | |
| 1620 return Fcar (Fread_from_string (stream, Qnil, Qnil)); | |
| 1621 | |
| 1622 return read0 (stream); | |
| 1623 } | |
| 1624 | |
| 1625 DEFUN ("read-from-string", Fread_from_string, 1, 3, 0, /* | |
| 1626 Read one Lisp expression which is represented as text by STRING. | |
| 1627 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX). | |
| 1628 START and END optionally delimit a substring of STRING from which to read; | |
| 1629 they default to 0 and (length STRING) respectively. | |
| 1630 */ | |
| 1631 (string, start, end)) | |
| 1632 { | |
| 1633 Bytecount startval, endval; | |
| 1634 Lisp_Object tem; | |
| 1635 Lisp_Object lispstream = Qnil; | |
| 1636 struct gcpro gcpro1; | |
| 1637 | |
| 1638 GCPRO1 (lispstream); | |
| 1639 CHECK_STRING (string); | |
| 1640 get_string_range_byte (string, start, end, &startval, &endval, | |
| 1641 GB_HISTORICAL_STRING_BEHAVIOR); | |
| 1642 lispstream = make_lisp_string_input_stream (string, startval, | |
| 1643 endval - startval); | |
| 1644 | |
| 1645 Vread_objects = Qnil; | |
| 1646 | |
| 1647 tem = read0 (lispstream); | |
| 1648 /* Yeah, it's ugly. Gonna make something of it? | |
| 1649 At least our reader is reentrant ... */ | |
| 1650 tem = | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1651 (Fcons (tem, make_fixnum |
| 793 | 1652 (string_index_byte_to_char |
| 771 | 1653 (string, |
| 428 | 1654 startval + Lstream_byte_count (XLSTREAM (lispstream)))))); |
| 1655 Lstream_delete (XLSTREAM (lispstream)); | |
| 1656 UNGCPRO; | |
| 1657 return tem; | |
| 1658 } | |
| 1659 | |
| 1660 | |
| 1661 | |
| 1662 /* Use this for recursive reads, in contexts where internal tokens | |
| 1663 are not allowed. See also read1(). */ | |
| 1664 static Lisp_Object | |
| 1665 read0 (Lisp_Object readcharfun) | |
| 1666 { | |
| 1667 Lisp_Object val = read1 (readcharfun); | |
| 1668 | |
| 1669 if (CONSP (val) && UNBOUNDP (XCAR (val))) | |
| 1670 { | |
| 867 | 1671 Ichar c = XCHAR (XCDR (val)); |
| 853 | 1672 free_cons (val); |
| 428 | 1673 return Fsignal (Qinvalid_read_syntax, |
| 1674 list1 (Fchar_to_string (make_char (c)))); | |
| 1675 } | |
| 1676 | |
| 1677 return val; | |
| 1678 } | |
| 3543 | 1679 |
| 1680 /* A Unicode escape, as in C# (though we only permit them in strings | |
| 1681 and characters, not arbitrarily in the source code.) */ | |
| 1682 static Ichar | |
| 1683 read_unicode_escape (Lisp_Object readcharfun, int unicode_hex_count) | |
| 1684 { | |
| 1685 REGISTER Ichar i = 0, c; | |
| 1686 REGISTER int count = 0; | |
| 1687 Lisp_Object lisp_char; | |
| 1688 while (++count <= unicode_hex_count) | |
| 1689 { | |
| 1690 c = readchar (readcharfun); | |
| 1691 /* Remember, can't use isdigit(), isalpha() etc. on Ichars */ | |
| 1692 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); | |
| 1693 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; | |
| 1694 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10; | |
| 1695 else | |
| 1696 { | |
| 1697 syntax_error ("Non-hex digit used for Unicode escape", | |
| 1698 make_char (c)); | |
| 1699 break; | |
| 1700 } | |
| 1701 } | |
| 1702 | |
| 4268 | 1703 if (i >= 0x110000 || i < 0) |
| 4096 | 1704 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1705 syntax_error ("Not a Unicode code point", make_fixnum(i)); |
| 4096 | 1706 } |
| 1707 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1708 lisp_char = Funicode_to_char(make_fixnum(i), Qnil); |
| 3543 | 1709 |
| 1710 if (EQ(Qnil, lisp_char)) | |
| 1711 { | |
| 4096 | 1712 /* Will happen on non-Mule. Silent corruption is what happens |
| 1713 elsewhere, and we used to do that to be consistent, but GNU error, | |
| 1714 so people writing portable code need to be able to handle that, and | |
| 1715 given a choice I prefer that behaviour. | |
| 1716 | |
| 1717 An undesirable aspect to this error is that the code point is shown | |
| 1718 as a decimal integer, which is mostly unreadable. */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1719 syntax_error ("Unsupported Unicode code point", make_fixnum(i)); |
| 3543 | 1720 } |
| 4096 | 1721 |
| 1722 return XCHAR(lisp_char); | |
| 3543 | 1723 } |
| 1724 | |
| 428 | 1725 |
| 867 | 1726 static Ichar |
| 428 | 1727 read_escape (Lisp_Object readcharfun) |
| 1728 { | |
| 1729 /* This function can GC */ | |
| 867 | 1730 Ichar c = readchar (readcharfun); |
| 428 | 1731 |
| 1732 if (c < 0) | |
| 563 | 1733 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 1734 |
| 1735 switch (c) | |
| 1736 { | |
| 1737 case 'a': return '\007'; | |
| 1738 case 'b': return '\b'; | |
| 1739 case 'd': return 0177; | |
| 1740 case 'e': return 033; | |
| 1741 case 'f': return '\f'; | |
| 1742 case 'n': return '\n'; | |
| 1743 case 'r': return '\r'; | |
| 1744 case 't': return '\t'; | |
| 1745 case 'v': return '\v'; | |
| 1746 case '\n': return -1; | |
| 1747 | |
| 1748 case 'M': | |
| 1749 c = readchar (readcharfun); | |
| 1750 if (c < 0) | |
| 563 | 1751 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 1752 if (c != '-') |
| 563 | 1753 syntax_error ("Invalid escape character syntax", Qunbound); |
| 428 | 1754 c = readchar (readcharfun); |
| 1755 if (c < 0) | |
| 563 | 1756 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 1757 if (c == '\\') |
| 1758 c = read_escape (readcharfun); | |
| 1759 return c | 0200; | |
| 1760 | |
| 1761 /* Originally, FSF_KEYS provided a degree of FSF Emacs | |
| 1762 compatibility by defining character "modifiers" alt, super, | |
| 1763 hyper and shift to infest the characters (i.e. integers). | |
| 1764 | |
| 1765 However, this doesn't cut it for XEmacs 20, which | |
| 1766 distinguishes characters from integers. Without Mule, ?\H-a | |
| 1767 simply returns ?a because every character is clipped into | |
| 1768 0-255. Under Mule it is much worse -- ?\H-a with FSF_KEYS | |
| 1769 produces an illegal character, and moves us to crash-land. | |
| 1770 | |
| 1771 For these reasons, FSF_KEYS hack is useless and without hope | |
| 1772 of ever working under XEmacs 20. */ | |
| 1773 #ifdef FSF_KEYS | |
| 831 | 1774 /* Deleted */ |
| 1775 #endif | |
| 428 | 1776 |
| 1777 case 'C': | |
| 1778 c = readchar (readcharfun); | |
| 1779 if (c < 0) | |
| 563 | 1780 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 1781 if (c != '-') |
| 563 | 1782 syntax_error ("Invalid escape character syntax", Qunbound); |
| 428 | 1783 case '^': |
| 1784 c = readchar (readcharfun); | |
| 1785 if (c < 0) | |
| 563 | 1786 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 1787 if (c == '\\') |
| 1788 c = read_escape (readcharfun); | |
| 1789 /* FSFmacs junk for non-ASCII controls. | |
| 1790 Not used here. */ | |
| 1791 if (c == '?') | |
| 1792 return 0177; | |
| 1793 else | |
| 1794 return c & (0200 | 037); | |
| 1795 | |
| 1796 case '0': | |
| 1797 case '1': | |
| 1798 case '2': | |
| 1799 case '3': | |
| 1800 case '4': | |
| 1801 case '5': | |
| 1802 case '6': | |
| 1803 case '7': | |
| 1804 /* An octal escape, as in ANSI C. */ | |
| 1805 { | |
| 867 | 1806 REGISTER Ichar i = c - '0'; |
| 428 | 1807 REGISTER int count = 0; |
| 1808 while (++count < 3) | |
| 1809 { | |
| 1810 if ((c = readchar (readcharfun)) >= '0' && c <= '7') | |
| 1811 i = (i << 3) + (c - '0'); | |
| 1812 else | |
| 1813 { | |
| 1814 unreadchar (readcharfun, c); | |
| 1815 break; | |
| 1816 } | |
| 1817 } | |
| 831 | 1818 if (i >= 0400) |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1819 { |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1820 read_syntax_error ((Ascbyte *) emacs_sprintf_malloc |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1821 (NULL, |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1822 "Non-ISO-8859-1 octal character escape, " |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1823 "?\\%.3o", i)); |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1824 } |
| 428 | 1825 return i; |
| 1826 } | |
| 1827 | |
| 1828 case 'x': | |
| 1829 /* A hex escape, as in ANSI C, except that we only allow latin-1 | |
| 1830 characters to be read this way. What is "\x4e03" supposed to | |
| 1831 mean, anyways, if the internal representation is hidden? | |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1832 This is also consistent with the treatment of octal escapes. |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1833 |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1834 Note that we don't accept ?\XAB as specifying the character with |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1835 numeric value 171; it must be ?\xAB. */ |
| 428 | 1836 { |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1837 #define OVERLONG_INFO "Overlong hex character escape, ?\\x" |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1838 |
| 867 | 1839 REGISTER Ichar i = 0; |
| 428 | 1840 REGISTER int count = 0; |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1841 Ascbyte seen[] = OVERLONG_INFO "\0\0\0\0\0"; |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1842 REGISTER Ascbyte *seenp = seen + sizeof (OVERLONG_INFO) - 1; |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1843 |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1844 #undef OVERLONG_INFO |
|
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1845 |
| 428 | 1846 while (++count <= 2) |
| 1847 { | |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1848 c = readchar (readcharfun), *seenp = c, ++seenp; |
| 867 | 1849 /* Remember, can't use isdigit(), isalpha() etc. on Ichars */ |
| 428 | 1850 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); |
| 1851 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; | |
| 1852 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10; | |
| 1853 else | |
| 1854 { | |
| 1855 unreadchar (readcharfun, c); | |
| 1856 break; | |
| 1857 } | |
| 1858 } | |
|
4483
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1859 |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1860 if (count == 3) |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1861 { |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1862 c = readchar (readcharfun), *seenp = c, ++seenp; |
|
4483
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1863 if ((c >= '0' && c <= '9') || |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1864 (c >= 'a' && c <= 'f') || |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1865 (c >= 'A' && c <= 'F')) |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1866 { |
|
5247
02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
1867 read_syntax_error (seen); |
|
4483
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1868 } |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1869 unreadchar (readcharfun, c); |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1870 } |
|
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1871 |
| 428 | 1872 return i; |
| 1873 } | |
| 3367 | 1874 case 'U': |
| 1875 /* Post-Unicode-2.0: Up to eight hex chars */ | |
| 3543 | 1876 return read_unicode_escape(readcharfun, 8); |
| 3367 | 1877 case 'u': |
| 3543 | 1878 /* Unicode-2.0 and before; four hex chars. */ |
| 1879 return read_unicode_escape(readcharfun, 4); | |
| 428 | 1880 |
| 1881 default: | |
| 1882 return c; | |
| 1883 } | |
| 1884 } | |
| 1885 | |
| 1886 | |
| 1887 | |
| 1888 /* read symbol-constituent stuff into `Vread_buffer_stream'. */ | |
| 1889 static Bytecount | |
| 867 | 1890 read_atom_0 (Lisp_Object readcharfun, Ichar firstchar, int *saw_a_backslash) |
| 428 | 1891 { |
| 1892 /* This function can GC */ | |
| 867 | 1893 Ichar c = ((firstchar) >= 0 ? firstchar : readchar (readcharfun)); |
| 428 | 1894 Lstream_rewind (XLSTREAM (Vread_buffer_stream)); |
| 1895 | |
| 1896 *saw_a_backslash = 0; | |
| 1897 | |
| 1898 while (c > 040 /* #### - comma should be here as should backquote */ | |
| 1899 && !(c == '\"' || c == '\'' || c == ';' | |
| 1900 || c == '(' || c == ')' | |
| 1901 || c == '[' || c == ']' || c == '#' | |
| 1902 )) | |
| 1903 { | |
| 1904 if (c == '\\') | |
| 1905 { | |
| 1906 c = readchar (readcharfun); | |
| 1907 if (c < 0) | |
| 563 | 1908 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 1909 *saw_a_backslash = 1; |
| 1910 } | |
| 867 | 1911 Lstream_put_ichar (XLSTREAM (Vread_buffer_stream), c); |
| 428 | 1912 QUIT; |
| 1913 c = readchar (readcharfun); | |
| 1914 } | |
| 1915 | |
| 1916 if (c >= 0) | |
| 1917 unreadchar (readcharfun, c); | |
| 1918 /* blasted terminating 0 */ | |
| 867 | 1919 Lstream_put_ichar (XLSTREAM (Vread_buffer_stream), 0); |
| 428 | 1920 Lstream_flush (XLSTREAM (Vread_buffer_stream)); |
| 1921 | |
| 1922 return Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) - 1; | |
| 1923 } | |
| 1924 | |
| 1925 static Lisp_Object | |
| 1926 read_atom (Lisp_Object readcharfun, | |
| 867 | 1927 Ichar firstchar, |
| 428 | 1928 int uninterned_symbol) |
| 1929 { | |
| 1930 /* This function can GC */ | |
| 1931 int saw_a_backslash; | |
| 1932 Bytecount len = read_atom_0 (readcharfun, firstchar, &saw_a_backslash); | |
| 1933 char *read_ptr = (char *) | |
| 1934 resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)); | |
| 1935 | |
| 1936 /* Is it an integer? */ | |
| 1937 if (! (saw_a_backslash || uninterned_symbol)) | |
| 1938 { | |
| 1939 /* If a token had any backslashes in it, it is disqualified from | |
| 1940 being an integer or a float. This means that 123\456 is a | |
| 1941 symbol, as is \123 (which is the way (intern "123") prints). | |
| 1942 Also, if token was preceded by #:, it's always a symbol. | |
| 1943 */ | |
| 1944 char *p = read_ptr + len; | |
| 1945 char *p1 = read_ptr; | |
| 1946 | |
| 1947 if (*p1 == '+' || *p1 == '-') p1++; | |
| 1948 if (p1 != p) | |
| 1949 { | |
| 1950 int c; | |
| 1951 | |
| 1952 while (p1 != p && (c = *p1) >= '0' && c <= '9') | |
| 1953 p1++; | |
| 1954 /* Integers can have trailing decimal points. */ | |
| 1955 if (p1 > read_ptr && p1 < p && *p1 == '.') | |
| 1956 p1++; | |
| 1957 if (p1 == p) | |
| 1958 { | |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1959 Ibyte *buf_end; |
| 428 | 1960 /* It is an integer. */ |
| 1961 if (p1[-1] == '.') | |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1962 { |
|
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1963 len -= 1; |
|
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1964 } |
|
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1965 |
|
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1966 return parse_integer ((Ibyte *) read_ptr, &buf_end, len, 10, |
|
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
1967 0, Qnil); |
| 428 | 1968 } |
| 1969 } | |
| 1983 | 1970 #ifdef HAVE_RATIO |
| 1971 if (isratio_string (read_ptr)) | |
| 1972 { | |
| 2013 | 1973 /* GMP ratio_set_string has no effect with initial + sign */ |
| 2010 | 1974 if (*read_ptr == '+') |
| 1975 read_ptr++; | |
| 1983 | 1976 ratio_set_string (scratch_ratio, read_ptr, 0); |
|
5088
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1977 if (bignum_sign (ratio_denominator (scratch_ratio)) != 0) { |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1978 ratio_canonicalize (scratch_ratio); |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1979 return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1980 } |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1981 return Fsignal (Qinvalid_read_syntax, |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1982 list2 (build_msg_string |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1983 ("Invalid ratio constant in reader"), |
|
207dad9e74f7
Signal an error upon reading 1/0.
Jerry James <james@xemacs.org>
parents:
5016
diff
changeset
|
1984 make_string ((Ibyte *) read_ptr, len))); |
| 1983 | 1985 } |
| 1986 #endif | |
| 428 | 1987 if (isfloat_string (read_ptr)) |
| 1988 return make_float (atof (read_ptr)); | |
| 1989 } | |
| 1990 | |
| 1991 { | |
| 1992 Lisp_Object sym; | |
| 1993 if (uninterned_symbol) | |
| 867 | 1994 sym = Fmake_symbol ( make_string ((Ibyte *) read_ptr, len)); |
| 428 | 1995 else |
| 1996 { | |
| 867 | 1997 Lisp_Object name = make_string ((Ibyte *) read_ptr, len); |
| 428 | 1998 sym = Fintern (name, Qnil); |
| 1999 } | |
| 2000 return sym; | |
| 2001 } | |
| 2002 } | |
| 2003 | |
| 2004 static Lisp_Object | |
| 2005 read_integer (Lisp_Object readcharfun, int base) | |
| 2006 { | |
| 2007 /* This function can GC */ | |
| 2008 int saw_a_backslash; | |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
2009 Ibyte *buf_end; |
| 428 | 2010 Bytecount len = read_atom_0 (readcharfun, -1, &saw_a_backslash); |
| 2011 return (parse_integer | |
| 2012 (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)), | |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
2013 &buf_end, len, base, 0, Qnil)); |
| 428 | 2014 } |
| 2015 | |
| 2016 static Lisp_Object | |
| 2017 read_bit_vector (Lisp_Object readcharfun) | |
| 2018 { | |
| 2019 unsigned_char_dynarr *dyn = Dynarr_new (unsigned_char); | |
| 440 | 2020 Lisp_Object val; |
| 428 | 2021 |
| 2022 while (1) | |
| 2023 { | |
| 444 | 2024 unsigned char bit; |
| 867 | 2025 Ichar c = readchar (readcharfun); |
| 444 | 2026 if (c == '0') |
| 2027 bit = 0; | |
| 2028 else if (c == '1') | |
| 2029 bit = 1; | |
| 2030 else | |
| 2031 { | |
| 2032 if (c >= 0) | |
| 2033 unreadchar (readcharfun, c); | |
| 2034 break; | |
| 2035 } | |
| 2036 Dynarr_add (dyn, bit); | |
| 428 | 2037 } |
| 2038 | |
| 4967 | 2039 val = make_bit_vector_from_byte_vector (Dynarr_begin (dyn), |
| 440 | 2040 Dynarr_length (dyn)); |
| 2041 Dynarr_free (dyn); | |
| 2042 | |
| 2043 return val; | |
| 428 | 2044 } |
| 2045 | |
| 2046 | |
| 2047 | |
| 2048 /* structures */ | |
| 2049 | |
| 2050 struct structure_type * | |
| 2051 define_structure_type (Lisp_Object type, | |
| 2052 int (*validate) (Lisp_Object data, | |
| 578 | 2053 Error_Behavior errb), |
| 428 | 2054 Lisp_Object (*instantiate) (Lisp_Object data)) |
| 2055 { | |
| 2056 struct structure_type st; | |
| 2057 | |
| 2058 st.type = type; | |
| 2059 st.keywords = Dynarr_new (structure_keyword_entry); | |
| 2060 st.validate = validate; | |
| 2061 st.instantiate = instantiate; | |
| 2062 Dynarr_add (the_structure_type_dynarr, st); | |
| 2063 | |
|
4844
91b3d00e717f
Various cleanups for Dynarr code, from Unicode-internal ws
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
2064 return Dynarr_lastp (the_structure_type_dynarr); |
| 428 | 2065 } |
| 2066 | |
| 2067 void | |
| 2068 define_structure_type_keyword (struct structure_type *st, Lisp_Object keyword, | |
| 2069 int (*validate) (Lisp_Object keyword, | |
| 2070 Lisp_Object value, | |
| 578 | 2071 Error_Behavior errb)) |
| 428 | 2072 { |
| 2073 struct structure_keyword_entry en; | |
| 2074 | |
| 2075 en.keyword = keyword; | |
| 2076 en.validate = validate; | |
| 2077 Dynarr_add (st->keywords, en); | |
| 2078 } | |
| 2079 | |
| 2080 static struct structure_type * | |
| 2081 recognized_structure_type (Lisp_Object type) | |
| 2082 { | |
| 2083 int i; | |
| 2084 | |
| 2085 for (i = 0; i < Dynarr_length (the_structure_type_dynarr); i++) | |
| 2086 { | |
| 2087 struct structure_type *st = Dynarr_atp (the_structure_type_dynarr, i); | |
| 2088 if (EQ (st->type, type)) | |
| 2089 return st; | |
| 2090 } | |
| 2091 | |
| 2092 return 0; | |
| 2093 } | |
| 2094 | |
| 2095 static Lisp_Object | |
| 2096 read_structure (Lisp_Object readcharfun) | |
| 2097 { | |
| 867 | 2098 Ichar c = readchar (readcharfun); |
| 428 | 2099 Lisp_Object list = Qnil; |
| 2100 Lisp_Object orig_list = Qnil; | |
| 2101 Lisp_Object already_seen = Qnil; | |
| 2102 int keyword_count; | |
| 2103 struct structure_type *st; | |
| 2104 struct gcpro gcpro1, gcpro2; | |
| 2105 | |
| 2106 GCPRO2 (orig_list, already_seen); | |
| 2107 if (c != '(') | |
| 442 | 2108 RETURN_UNGCPRO (continuable_read_syntax_error ("#s not followed by paren")); |
| 428 | 2109 list = read_list (readcharfun, ')', 0, 0); |
| 2110 orig_list = list; | |
| 2111 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2112 int len = XFIXNUM (Flength (list)); |
| 428 | 2113 if (len == 0) |
| 442 | 2114 RETURN_UNGCPRO (continuable_read_syntax_error |
| 428 | 2115 ("structure type not specified")); |
| 2116 if (!(len & 1)) | |
| 2117 RETURN_UNGCPRO | |
| 442 | 2118 (continuable_read_syntax_error |
| 428 | 2119 ("structures must have alternating keyword/value pairs")); |
| 2120 } | |
| 2121 | |
| 2122 st = recognized_structure_type (XCAR (list)); | |
| 2123 if (!st) | |
| 2124 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
| 771 | 2125 list2 (build_msg_string |
| 428 | 2126 ("unrecognized structure type"), |
| 2127 XCAR (list)))); | |
| 2128 | |
| 2129 list = Fcdr (list); | |
| 2130 keyword_count = Dynarr_length (st->keywords); | |
| 2131 while (!NILP (list)) | |
| 2132 { | |
| 2133 Lisp_Object keyword, value; | |
| 2134 int i; | |
| 2135 struct structure_keyword_entry *en = NULL; | |
| 2136 | |
| 2137 keyword = Fcar (list); | |
| 2138 list = Fcdr (list); | |
| 2139 value = Fcar (list); | |
| 2140 list = Fcdr (list); | |
| 2141 | |
| 2142 if (!NILP (memq_no_quit (keyword, already_seen))) | |
| 2143 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
| 771 | 2144 list2 (build_msg_string |
| 428 | 2145 ("structure keyword already seen"), |
| 2146 keyword))); | |
| 2147 | |
| 2148 for (i = 0; i < keyword_count; i++) | |
| 2149 { | |
| 2150 en = Dynarr_atp (st->keywords, i); | |
| 2151 if (EQ (keyword, en->keyword)) | |
| 2152 break; | |
| 2153 } | |
| 2154 | |
| 2155 if (i == keyword_count) | |
| 2156 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
| 771 | 2157 list2 (build_msg_string |
| 428 | 2158 ("unrecognized structure keyword"), |
| 2159 keyword))); | |
| 2160 | |
| 2161 if (en->validate && ! (en->validate) (keyword, value, ERROR_ME)) | |
| 2162 RETURN_UNGCPRO | |
| 2163 (Fsignal (Qinvalid_read_syntax, | |
| 771 | 2164 list3 (build_msg_string |
| 428 | 2165 ("invalid value for structure keyword"), |
| 2166 keyword, value))); | |
| 2167 | |
| 2168 already_seen = Fcons (keyword, already_seen); | |
| 2169 } | |
| 2170 | |
| 2171 if (st->validate && ! (st->validate) (orig_list, ERROR_ME)) | |
| 2172 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
| 771 | 2173 list2 (build_msg_string |
| 428 | 2174 ("invalid structure initializer"), |
| 2175 orig_list))); | |
| 2176 | |
| 2177 RETURN_UNGCPRO ((st->instantiate) (XCDR (orig_list))); | |
| 2178 } | |
| 2179 | |
| 2180 | |
| 2181 static Lisp_Object read_compiled_function (Lisp_Object readcharfun, | |
| 2182 int terminator); | |
| 2183 static Lisp_Object read_vector (Lisp_Object readcharfun, int terminator); | |
| 2184 | |
| 2185 /* Get the next character; filter out whitespace and comments */ | |
| 2186 | |
| 867 | 2187 static Ichar |
| 428 | 2188 reader_nextchar (Lisp_Object readcharfun) |
| 2189 { | |
| 2190 /* This function can GC */ | |
| 867 | 2191 Ichar c; |
| 428 | 2192 |
| 2193 retry: | |
| 2194 QUIT; | |
| 2195 c = readchar (readcharfun); | |
| 2196 if (c < 0) | |
| 563 | 2197 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
| 428 | 2198 |
| 2199 switch (c) | |
| 2200 { | |
| 2201 default: | |
| 2202 { | |
| 2203 /* Ignore whitespace and control characters */ | |
| 2204 if (c <= 040) | |
| 2205 goto retry; | |
| 2206 return c; | |
| 2207 } | |
| 2208 | |
| 2209 case ';': | |
| 2210 { | |
| 2211 /* Comment */ | |
| 2212 while ((c = readchar (readcharfun)) >= 0 && c != '\n') | |
| 2213 QUIT; | |
| 2214 goto retry; | |
| 2215 } | |
| 2216 } | |
| 2217 } | |
| 2218 | |
| 2219 #if 0 | |
| 2220 static Lisp_Object | |
| 2221 list2_pure (int pure, Lisp_Object a, Lisp_Object b) | |
| 2222 { | |
| 2223 return pure ? pure_cons (a, pure_cons (b, Qnil)) : list2 (a, b); | |
| 2224 } | |
| 2225 #endif | |
| 2226 | |
| 3543 | 2227 static Lisp_Object |
| 2228 read_string (Lisp_Object readcharfun, Ichar delim, int raw, | |
| 2229 int honor_unicode) | |
| 2230 { | |
| 2231 #ifdef I18N3 | |
| 2232 /* #### If the input stream is translating, then the string | |
| 2233 should be marked as translatable by setting its | |
| 2234 `string-translatable' property to t. .el and .elc files | |
| 2235 normally are translating input streams. See Fgettext() | |
| 2236 and print_internal(). */ | |
| 2237 #endif | |
| 2238 Ichar c; | |
| 2239 int cancel = 0; | |
| 2240 | |
| 2241 Lstream_rewind(XLSTREAM(Vread_buffer_stream)); | |
| 2242 while ((c = readchar(readcharfun)) >= 0 && c != delim) | |
| 2243 { | |
| 2244 if (c == '\\') | |
| 2245 { | |
| 2246 if (raw) | |
| 2247 { | |
| 2248 c = readchar(readcharfun); | |
| 2249 if (honor_unicode && ('u' == c || 'U' == c)) | |
| 2250 { | |
| 2251 c = read_unicode_escape(readcharfun, | |
| 2252 'U' == c ? 8 : 4); | |
| 2253 } | |
| 2254 else | |
| 2255 { | |
| 2256 /* For raw strings, insert the | |
| 2257 backslash and the next char, */ | |
| 2258 Lstream_put_ichar(XLSTREAM | |
| 2259 (Vread_buffer_stream), | |
| 2260 '\\'); | |
| 2261 } | |
| 2262 } | |
| 2263 else | |
| 2264 /* otherwise, backslash escapes the next char. */ | |
| 2265 c = read_escape(readcharfun); | |
| 2266 } | |
| 2267 /* c is -1 if \ newline has just been seen */ | |
| 2268 if (c == -1) | |
| 2269 { | |
| 2270 if (Lstream_byte_count | |
| 2271 (XLSTREAM(Vread_buffer_stream)) == | |
| 2272 0) | |
| 2273 cancel = 1; | |
| 2274 } | |
| 2275 else | |
| 2276 Lstream_put_ichar(XLSTREAM | |
| 2277 (Vread_buffer_stream), | |
| 2278 c); | |
| 2279 QUIT; | |
| 2280 } | |
| 2281 if (c < 0) | |
| 2282 return Fsignal(Qend_of_file, | |
| 2283 list1(READCHARFUN_MAYBE(readcharfun))); | |
| 2284 | |
| 2285 /* If purifying, and string starts with \ newline, | |
| 2286 return zero instead. This is for doc strings | |
| 2287 that we are really going to find in lib-src/DOC.nn.nn */ | |
| 2288 if (purify_flag && NILP(Vinternal_doc_file_name) | |
| 2289 && cancel) | |
| 2290 return Qzero; | |
| 2291 | |
| 2292 Lstream_flush(XLSTREAM(Vread_buffer_stream)); | |
| 2293 return make_string(resizing_buffer_stream_ptr | |
| 2294 (XLSTREAM(Vread_buffer_stream)), | |
| 2295 Lstream_byte_count(XLSTREAM(Vread_buffer_stream))); | |
| 2296 } | |
| 2297 | |
| 2298 static Lisp_Object | |
| 2299 read_raw_string (Lisp_Object readcharfun) | |
| 2300 { | |
| 2301 Ichar c; | |
| 2302 Ichar permit_unicode = 0; | |
| 2303 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2304 do |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2305 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2306 c = reader_nextchar (readcharfun); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2307 switch (c) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2308 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2309 /* #r:engine"my sexy raw string" -- raw string w/ flags*/ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2310 /* case ':': */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2311 /* #ru"Hi there\u20AC \U000020AC" -- raw string, honouring Unicode. */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2312 case 'u': |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2313 case 'U': |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2314 permit_unicode = c; |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2315 continue; |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2316 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2317 /* #r"my raw string" -- raw string */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2318 case '\"': |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2319 return read_string (readcharfun, '\"', 1, permit_unicode); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2320 /* invalid syntax */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2321 default: |
| 3543 | 2322 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2323 if (permit_unicode) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2324 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2325 unreadchar (readcharfun, permit_unicode); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2326 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2327 unreadchar (readcharfun, c); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2328 return Fsignal (Qinvalid_read_syntax, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2329 list1 (build_msg_string |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2330 ("unrecognized raw string syntax"))); |
| 3543 | 2331 } |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2332 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2333 } while (1); |
| 3543 | 2334 } |
| 2335 | |
| 428 | 2336 /* Read the next Lisp object from the stream READCHARFUN and return it. |
| 2337 If the return value is a cons whose car is Qunbound, then read1() | |
| 2338 encountered a misplaced token (e.g. a right bracket, right paren, | |
| 2339 or dot followed by a non-number). To filter this stuff out, | |
| 2340 use read0(). */ | |
| 2341 | |
| 2342 static Lisp_Object | |
| 2343 read1 (Lisp_Object readcharfun) | |
| 2344 { | |
| 867 | 2345 Ichar c; |
| 428 | 2346 |
| 2347 retry: | |
| 2348 c = reader_nextchar (readcharfun); | |
| 2349 | |
| 2350 switch (c) | |
| 2351 { | |
| 2352 case '(': | |
| 2353 { | |
| 2354 #ifdef LISP_BACKQUOTES /* old backquote compatibility in lisp reader */ | |
| 2355 /* if this is disabled, then other code in eval.c must be enabled */ | |
| 867 | 2356 Ichar ch = reader_nextchar (readcharfun); |
| 428 | 2357 switch (ch) |
| 2358 { | |
| 2359 case '`': | |
| 2360 { | |
| 2361 Lisp_Object tem; | |
| 853 | 2362 int speccount = internal_bind_int (&old_backquote_flag, |
| 2363 1 + old_backquote_flag); | |
| 428 | 2364 tem = read0 (readcharfun); |
| 771 | 2365 unbind_to (speccount); |
| 428 | 2366 ch = reader_nextchar (readcharfun); |
| 2367 if (ch != ')') | |
| 2368 { | |
| 2369 unreadchar (readcharfun, ch); | |
| 2370 return Fsignal (Qinvalid_read_syntax, | |
| 771 | 2371 list1 (build_msg_string |
| 428 | 2372 ("Weird old-backquote syntax"))); |
| 2373 } | |
| 2374 return list2 (Qbacktick, tem); | |
| 2375 } | |
| 2376 case ',': | |
| 2377 { | |
| 2378 if (old_backquote_flag) | |
| 2379 { | |
| 2380 Lisp_Object tem, comma_type; | |
| 2381 ch = readchar (readcharfun); | |
| 2382 if (ch == '@') | |
| 2383 comma_type = Qcomma_at; | |
| 2384 else | |
| 2385 { | |
| 2386 if (ch >= 0) | |
| 2387 unreadchar (readcharfun, ch); | |
| 2388 comma_type = Qcomma; | |
| 2389 } | |
| 2390 tem = read0 (readcharfun); | |
| 2391 ch = reader_nextchar (readcharfun); | |
| 2392 if (ch != ')') | |
| 2393 { | |
| 2394 unreadchar (readcharfun, ch); | |
| 2395 return Fsignal (Qinvalid_read_syntax, | |
| 771 | 2396 list1 (build_msg_string |
| 428 | 2397 ("Weird old-backquote syntax"))); |
| 2398 } | |
| 2399 return list2 (comma_type, tem); | |
| 2400 } | |
| 2401 else | |
| 2402 { | |
| 2403 unreadchar (readcharfun, ch); | |
| 2404 #if 0 | |
| 2405 return Fsignal (Qinvalid_read_syntax, | |
| 771 | 2406 list1 (build_msg_string ("Comma outside of backquote"))); |
| 428 | 2407 #else |
| 2408 /* #### - yuck....but this is reverse compatible. */ | |
| 2409 /* mostly this is required by edebug, which does its own | |
| 2410 annotated reading. We need to have an annotated_read | |
| 2411 function that records (with markers) the buffer | |
| 2412 positions of the elements that make up lists, then that | |
| 2413 can be used in edebug and bytecomp and the check above | |
| 2414 can go back in. --Stig */ | |
| 2415 break; | |
| 2416 #endif | |
| 2417 } | |
| 2418 } | |
| 2419 default: | |
| 2420 unreadchar (readcharfun, ch); | |
| 2421 } /* switch(ch) */ | |
| 2422 #endif /* old backquote crap... */ | |
| 2423 return read_list (readcharfun, ')', 1, 1); | |
| 2424 } | |
| 2425 case '[': | |
| 2426 return read_vector (readcharfun, ']'); | |
| 2427 | |
| 2428 case ')': | |
| 2429 case ']': | |
| 2430 /* #### - huh? these don't do what they seem... */ | |
| 2431 return noseeum_cons (Qunbound, make_char (c)); | |
| 2432 case '.': | |
| 2433 { | |
| 2434 /* If a period is followed by a number, then we should read it | |
| 2435 as a floating point number. Otherwise, it denotes a dotted | |
| 2436 pair. | |
| 2437 */ | |
| 2438 c = readchar (readcharfun); | |
| 2439 unreadchar (readcharfun, c); | |
| 2440 | |
| 867 | 2441 /* Can't use isdigit on Ichars */ |
| 428 | 2442 if (c < '0' || c > '9') |
| 2443 return noseeum_cons (Qunbound, make_char ('.')); | |
| 2444 | |
| 2445 /* Note that read_atom will loop | |
| 2446 at least once, assuring that we will not try to UNREAD | |
| 2447 two characters in a row. | |
| 2448 (I think this doesn't matter anymore because there should | |
| 2449 be no more danger in unreading multiple characters) */ | |
| 2450 return read_atom (readcharfun, '.', 0); | |
| 2451 } | |
| 2452 | |
| 2453 case '#': | |
| 2454 { | |
| 2455 c = readchar (readcharfun); | |
| 2456 switch (c) | |
| 2457 { | |
| 2458 #if 0 /* FSFmacs silly char-table syntax */ | |
| 2459 case '^': | |
| 2460 #endif | |
| 2461 #if 0 /* FSFmacs silly bool-vector syntax */ | |
| 2462 case '&': | |
| 2463 #endif | |
| 2464 /* "#["-- byte-code constant syntax */ | |
| 2465 /* purecons #[...] syntax */ | |
| 2466 case '[': return read_compiled_function (readcharfun, ']' | |
| 2467 /*, purify_flag */ ); | |
| 2468 /* "#:"-- gensym syntax */ | |
| 2469 case ':': return read_atom (readcharfun, -1, 1); | |
| 2470 /* #'x => (function x) */ | |
| 2471 case '\'': return list2 (Qfunction, read0 (readcharfun)); | |
| 2472 #if 0 | |
| 2473 /* RMS uses this syntax for fat-strings. | |
| 2474 If we use it for vectors, then obscure bugs happen. | |
| 2475 */ | |
| 2476 /* "#(" -- Scheme/CL vector syntax */ | |
| 2477 case '(': return read_vector (readcharfun, ')'); | |
| 2478 #endif | |
| 2479 #if 0 /* FSFmacs */ | |
| 2480 case '(': | |
| 2481 { | |
| 2482 Lisp_Object tmp; | |
| 2483 struct gcpro gcpro1; | |
| 2484 | |
| 2485 /* Read the string itself. */ | |
| 2486 tmp = read1 (readcharfun); | |
| 2487 if (!STRINGP (tmp)) | |
| 2488 { | |
| 2489 if (CONSP (tmp) && UNBOUNDP (XCAR (tmp))) | |
| 853 | 2490 free_cons (tmp); |
| 428 | 2491 return Fsignal (Qinvalid_read_syntax, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2492 list1 (build_ascstring ("#"))); |
| 428 | 2493 } |
| 2494 GCPRO1 (tmp); | |
| 2495 /* Read the intervals and their properties. */ | |
| 2496 while (1) | |
| 2497 { | |
| 2498 Lisp_Object beg, end, plist; | |
| 867 | 2499 Ichar ch; |
| 428 | 2500 int invalid = 0; |
| 2501 | |
| 2502 beg = read1 (readcharfun); | |
| 2503 if (CONSP (beg) && UNBOUNDP (XCAR (beg))) | |
| 2504 { | |
| 2505 ch = XCHAR (XCDR (beg)); | |
| 853 | 2506 free_cons (beg); |
| 428 | 2507 if (ch == ')') |
| 2508 break; | |
| 2509 else | |
| 2510 invalid = 1; | |
| 2511 } | |
| 2512 if (!invalid) | |
| 2513 { | |
| 2514 end = read1 (readcharfun); | |
| 2515 if (CONSP (end) && UNBOUNDP (XCAR (end))) | |
| 2516 { | |
| 853 | 2517 free_cons (end); |
| 428 | 2518 invalid = 1; |
| 2519 } | |
| 2520 } | |
| 2521 if (!invalid) | |
| 2522 { | |
| 2523 plist = read1 (readcharfun); | |
| 2524 if (CONSP (plist) && UNBOUNDP (XCAR (plist))) | |
| 2525 { | |
| 853 | 2526 free_cons (plist); |
| 428 | 2527 invalid = 1; |
| 2528 } | |
| 2529 } | |
| 2530 if (invalid) | |
| 2531 RETURN_UNGCPRO | |
| 2532 (Fsignal (Qinvalid_read_syntax, | |
| 2533 list2 | |
| 771 | 2534 (build_msg_string ("invalid string property list"), |
| 428 | 2535 XCDR (plist)))); |
| 2536 Fset_text_properties (beg, end, plist, tmp); | |
| 2537 } | |
| 2538 UNGCPRO; | |
| 2539 return tmp; | |
| 2540 } | |
| 2541 #endif /* 0 */ | |
| 2542 case '@': | |
| 2543 { | |
| 2544 /* #@NUMBER is used to skip NUMBER following characters. | |
| 2545 That's used in .elc files to skip over doc strings | |
| 2546 and function definitions. */ | |
| 2547 int i, nskip = 0; | |
| 2548 | |
| 2549 /* Read a decimal integer. */ | |
| 2550 while ((c = readchar (readcharfun)) >= 0 | |
| 2551 && c >= '0' && c <= '9') | |
| 2552 nskip = (10 * nskip) + (c - '0'); | |
| 2553 if (c >= 0) | |
| 2554 unreadchar (readcharfun, c); | |
| 2555 | |
| 2556 /* FSF has code here that maybe caches the skipped | |
| 2557 string. See above for why this is totally | |
| 2558 losing. We handle this differently. */ | |
| 2559 | |
| 2560 /* Skip that many characters. */ | |
| 2561 for (i = 0; i < nskip && c >= 0; i++) | |
| 2562 c = readchar (readcharfun); | |
| 2563 | |
| 2564 goto retry; | |
| 2565 } | |
|
5677
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5610
diff
changeset
|
2566 /* The interned symbol with the empty name. */ |
|
febc025c4e0c
Adopt GNU's ## syntax for the interned symbol with name "".
Aidan Kehoe <kehoea@parhasard.net>
parents:
5610
diff
changeset
|
2567 case '#': return intern (""); |
| 428 | 2568 case '$': return Vload_file_name_internal; |
| 2569 /* bit vectors */ | |
| 2570 case '*': return read_bit_vector (readcharfun); | |
| 2571 /* #o10 => 8 -- octal constant syntax */ | |
|
5213
7abb91db1e64
Accept #B<binary>, #O<octal>, and #X<hex>.
Mike Sperber <sperber@deinprogramm.de>
parents:
5211
diff
changeset
|
2572 case 'o': case 'O': return read_integer (readcharfun, 8); |
| 428 | 2573 /* #xdead => 57005 -- hex constant syntax */ |
|
5213
7abb91db1e64
Accept #B<binary>, #O<octal>, and #X<hex>.
Mike Sperber <sperber@deinprogramm.de>
parents:
5211
diff
changeset
|
2574 case 'x': case 'X': return read_integer (readcharfun, 16); |
| 428 | 2575 /* #b010 => 2 -- binary constant syntax */ |
|
5213
7abb91db1e64
Accept #B<binary>, #O<octal>, and #X<hex>.
Mike Sperber <sperber@deinprogramm.de>
parents:
5211
diff
changeset
|
2576 case 'b': case 'B': return read_integer (readcharfun, 2); |
| 3543 | 2577 /* #r"raw\stringt" -- raw string syntax */ |
| 2578 case 'r': return read_raw_string(readcharfun); | |
| 428 | 2579 /* #s(foobar key1 val1 key2 val2) -- structure syntax */ |
| 2580 case 's': return read_structure (readcharfun); | |
| 2581 case '<': | |
| 2582 { | |
| 2583 unreadchar (readcharfun, c); | |
| 2584 return Fsignal (Qinvalid_read_syntax, | |
| 771 | 2585 list1 (build_msg_string ("Cannot read unreadable object"))); |
| 428 | 2586 } |
| 2587 #ifdef FEATUREP_SYNTAX | |
| 2588 case '+': | |
| 2589 case '-': | |
| 2590 { | |
| 456 | 2591 Lisp_Object feature_exp, obj, tem; |
| 428 | 2592 struct gcpro gcpro1, gcpro2; |
| 2593 | |
| 456 | 2594 feature_exp = read0(readcharfun); |
| 428 | 2595 obj = read0(readcharfun); |
| 2596 | |
| 2597 /* the call to `featurep' may GC. */ | |
| 456 | 2598 GCPRO2 (feature_exp, obj); |
| 2599 tem = call1 (Qfeaturep, feature_exp); | |
| 428 | 2600 UNGCPRO; |
| 2601 | |
| 2602 if (c == '+' && NILP(tem)) goto retry; | |
| 2603 if (c == '-' && !NILP(tem)) goto retry; | |
| 2604 return obj; | |
| 2605 } | |
| 2606 #endif | |
| 2607 case '0': case '1': case '2': case '3': case '4': | |
| 2608 case '5': case '6': case '7': case '8': case '9': | |
| 2609 /* Reader forms that can reuse previously read objects. */ | |
| 2610 { | |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2611 Lisp_Object parsed, found; |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
2612 Ibyte *buf_end; |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2613 |
|
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2614 Lstream_rewind (XLSTREAM (Vread_buffer_stream)); |
| 428 | 2615 |
| 2616 /* Using read_integer() here is impossible, because it | |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2617 chokes on `='. */ |
| 428 | 2618 while (c >= '0' && c <= '9') |
| 2619 { | |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2620 Lstream_put_ichar (XLSTREAM (Vread_buffer_stream), c); |
|
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2621 QUIT; |
| 428 | 2622 c = readchar (readcharfun); |
| 2623 } | |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2624 |
|
5606
7c383c5784ed
Zero-terminate when passing strings to parse_integer(), lread.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5605
diff
changeset
|
2625 /* blasted terminating 0 */ |
|
7c383c5784ed
Zero-terminate when passing strings to parse_integer(), lread.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5605
diff
changeset
|
2626 Lstream_put_ichar (XLSTREAM (Vread_buffer_stream), 0); |
|
5610
d69ea1ff4ce3
Add the zero, *then* flush, when reading integers for the #N=... syntax.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5606
diff
changeset
|
2627 Lstream_flush (XLSTREAM (Vread_buffer_stream)); |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2628 |
|
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2629 parsed |
|
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2630 = parse_integer (resizing_buffer_stream_ptr |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
2631 (XLSTREAM (Vread_buffer_stream)), &buf_end, |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2632 Lstream_byte_count (XLSTREAM |
|
5606
7c383c5784ed
Zero-terminate when passing strings to parse_integer(), lread.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5605
diff
changeset
|
2633 (Vread_buffer_stream)) |
|
5864
750fab17b299
Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5814
diff
changeset
|
2634 - 1, 10, 0, Qnil); |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2635 |
|
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2636 found = assoc_no_quit (parsed, Vread_objects); |
| 428 | 2637 if (c == '=') |
| 2638 { | |
| 2639 /* #n=object returns object, but associates it with | |
| 2640 n for #n#. */ | |
| 2641 if (CONSP (found)) | |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2642 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2643 return Fsignal (Qinvalid_read_syntax, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2644 list2 (build_msg_string |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2645 ("Multiply defined object label"), |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2646 parsed)); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2647 } |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2648 else |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2649 { |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2650 Lisp_Object object; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2651 |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2652 found = Fcons (parsed, Qnil); |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2653 /* Make FOUND a placeholder for the object that will |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2654 be read. (We've just consed it, and it's not |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2655 visible from Lisp, so there's no possibility of |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2656 confusing it with something else in the read |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2657 structure.) */ |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2658 XSETCDR (found, found); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2659 Vread_objects = Fcons (found, Vread_objects); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2660 object = read0 (readcharfun); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2661 XSETCDR (found, object); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2662 |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2663 nsubst_structures (object, found, object, check_eq_nokey, |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2664 1, Qeq, Qnil); |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2665 return object; |
|
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5489
diff
changeset
|
2666 } |
| 428 | 2667 } |
| 2668 else if (c == '#') | |
| 2669 { | |
| 2670 /* #n# returns a previously read object. */ | |
| 2671 if (CONSP (found)) | |
| 2672 return XCDR (found); | |
| 2673 else | |
| 2674 return Fsignal (Qinvalid_read_syntax, | |
| 771 | 2675 list2 (build_msg_string |
| 428 | 2676 ("Undefined symbol label"), |
|
5605
cc7f8a0e569a
Accept bignums unambiguously in the syntax for object labels, lread.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
2677 parsed)); |
| 428 | 2678 } |
| 2679 return Fsignal (Qinvalid_read_syntax, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2680 list1 (build_ascstring ("#"))); |
| 428 | 2681 } |
| 2682 default: | |
| 2683 { | |
| 2684 unreadchar (readcharfun, c); | |
| 2685 return Fsignal (Qinvalid_read_syntax, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
2686 list1 (build_ascstring ("#"))); |
| 428 | 2687 } |
| 2688 } | |
| 2689 } | |
| 2690 | |
| 2691 /* Quote */ | |
| 2692 case '\'': return list2 (Qquote, read0 (readcharfun)); | |
| 2693 | |
| 2694 #ifdef LISP_BACKQUOTES | |
| 2695 case '`': | |
| 2696 { | |
| 2697 Lisp_Object tem; | |
| 853 | 2698 int speccount = internal_bind_int (&new_backquote_flag, |
| 2699 1 + new_backquote_flag); | |
| 428 | 2700 tem = read0 (readcharfun); |
| 771 | 2701 unbind_to (speccount); |
| 428 | 2702 return list2 (Qbackquote, tem); |
| 2703 } | |
| 2704 | |
| 2705 case ',': | |
| 2706 { | |
| 2707 if (new_backquote_flag) | |
| 2708 { | |
| 2709 Lisp_Object comma_type = Qnil; | |
| 2710 int ch = readchar (readcharfun); | |
| 2711 | |
| 2712 if (ch == '@') | |
| 2713 comma_type = Qcomma_at; | |
| 2714 else if (ch == '.') | |
| 2715 comma_type = Qcomma_dot; | |
| 2716 else | |
| 2717 { | |
| 2718 if (ch >= 0) | |
| 2719 unreadchar (readcharfun, ch); | |
| 2720 comma_type = Qcomma; | |
| 2721 } | |
| 2722 return list2 (comma_type, read0 (readcharfun)); | |
| 2723 } | |
| 2724 else | |
| 2725 { | |
| 2726 /* YUCK. 99.999% backwards compatibility. The Right | |
| 2727 Thing(tm) is to signal an error here, because it's | |
| 2728 really invalid read syntax. Instead, this permits | |
| 2729 commas to begin symbols (unless they're inside | |
| 2730 backquotes). If an error is signalled here in the | |
| 2731 future, then commas should be invalid read syntax | |
| 2732 outside of backquotes anywhere they're found (i.e. | |
| 2733 they must be quoted in symbols) -- Stig */ | |
| 2734 return read_atom (readcharfun, c, 0); | |
| 2735 } | |
| 2736 } | |
| 2737 #endif | |
| 2738 | |
| 2739 case '?': | |
| 2740 { | |
| 2741 /* Evil GNU Emacs "character" (ie integer) syntax */ | |
| 2742 c = readchar (readcharfun); | |
| 2743 if (c < 0) | |
| 2744 return Fsignal (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun))); | |
| 2745 | |
| 2746 if (c == '\\') | |
| 2747 c = read_escape (readcharfun); | |
| 4439 | 2748 if (c < 0) |
| 2749 return Fsignal (Qinvalid_read_syntax, list1 (READCHARFUN_MAYBE (readcharfun))); | |
| 428 | 2750 return make_char (c); |
| 2751 } | |
| 2752 | |
| 2753 case '\"': | |
| 3543 | 2754 /* String */ |
| 2755 return read_string(readcharfun, '\"', 0, 1); | |
| 428 | 2756 |
| 2757 default: | |
| 2758 { | |
| 2759 /* Ignore whitespace and control characters */ | |
| 2760 if (c <= 040) | |
| 2761 goto retry; | |
| 2762 return read_atom (readcharfun, c, 0); | |
| 2763 } | |
| 2764 } | |
| 2765 } | |
| 2766 | |
| 2767 | |
| 2768 | |
| 2769 #define LEAD_INT 1 | |
| 2770 #define DOT_CHAR 2 | |
| 2771 #define TRAIL_INT 4 | |
| 2772 #define E_CHAR 8 | |
| 2773 #define EXP_INT 16 | |
| 2774 | |
| 2775 int | |
| 442 | 2776 isfloat_string (const char *cp) |
| 428 | 2777 { |
| 2778 int state = 0; | |
| 867 | 2779 const Ibyte *ucp = (const Ibyte *) cp; |
| 428 | 2780 |
| 2781 if (*ucp == '+' || *ucp == '-') | |
| 2782 ucp++; | |
| 2783 | |
| 2784 if (*ucp >= '0' && *ucp <= '9') | |
| 2785 { | |
| 2786 state |= LEAD_INT; | |
| 2787 while (*ucp >= '0' && *ucp <= '9') | |
| 2788 ucp++; | |
| 2789 } | |
| 2790 if (*ucp == '.') | |
| 2791 { | |
| 2792 state |= DOT_CHAR; | |
| 2793 ucp++; | |
| 2794 } | |
| 2795 if (*ucp >= '0' && *ucp <= '9') | |
| 2796 { | |
| 2797 state |= TRAIL_INT; | |
| 2798 while (*ucp >= '0' && *ucp <= '9') | |
| 2799 ucp++; | |
| 2800 } | |
| 2801 if (*ucp == 'e' || *ucp == 'E') | |
| 2802 { | |
| 2803 state |= E_CHAR; | |
| 2804 ucp++; | |
| 2805 if ((*ucp == '+') || (*ucp == '-')) | |
| 2806 ucp++; | |
| 2807 } | |
| 2808 | |
| 2809 if (*ucp >= '0' && *ucp <= '9') | |
| 2810 { | |
| 2811 state |= EXP_INT; | |
| 2812 while (*ucp >= '0' && *ucp <= '9') | |
| 2813 ucp++; | |
| 2814 } | |
| 2815 return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') || (*ucp == '\n') | |
| 2816 || (*ucp == '\r') || (*ucp == '\f')) | |
| 2817 && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT) | |
| 2818 || state == (DOT_CHAR|TRAIL_INT) | |
| 2819 || state == (LEAD_INT|E_CHAR|EXP_INT) | |
| 2820 || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT) | |
| 2821 || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT))); | |
| 2822 } | |
| 1983 | 2823 |
| 2824 int | |
| 2825 isratio_string (const char *cp) | |
| 2826 { | |
| 2010 | 2827 /* Possible minus/plus sign */ |
| 2828 if (*cp == '-' || *cp == '+') | |
| 1983 | 2829 cp++; |
| 2830 | |
| 2831 /* Numerator */ | |
| 2832 if (*cp < '0' || *cp > '9') | |
| 2833 return 0; | |
| 2834 | |
| 2835 do { | |
| 2836 cp++; | |
| 2837 } while (*cp >= '0' && *cp <= '9'); | |
| 2838 | |
| 2839 /* Slash */ | |
| 2840 if (*cp++ != '/') | |
| 2841 return 0; | |
| 2842 | |
| 2843 /* Denominator */ | |
| 2844 if (*cp < '0' || *cp > '9') | |
| 2845 return 0; | |
| 2846 | |
| 2847 do { | |
| 2848 cp++; | |
| 2849 } while (*cp >= '0' && *cp <= '9'); | |
| 2850 | |
| 2851 return *cp == '\0' || *cp == ' ' || *cp =='\t' || *cp == '\n' || | |
| 2852 *cp == '\r' || *cp == '\f'; | |
| 2853 } | |
|
5243
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5228
diff
changeset
|
2854 |
| 428 | 2855 |
| 2856 static void * | |
| 2857 sequence_reader (Lisp_Object readcharfun, | |
| 867 | 2858 Ichar terminator, |
| 428 | 2859 void *state, |
| 2860 void * (*conser) (Lisp_Object readcharfun, | |
| 2861 void *state, Charcount len)) | |
| 2862 { | |
| 2863 Charcount len; | |
| 2864 | |
| 2865 for (len = 0; ; len++) | |
| 2866 { | |
| 867 | 2867 Ichar ch; |
| 428 | 2868 |
| 2869 QUIT; | |
| 2870 ch = reader_nextchar (readcharfun); | |
| 2871 | |
| 2872 if (ch == terminator) | |
| 2873 return state; | |
| 2874 else | |
| 2875 unreadchar (readcharfun, ch); | |
| 2876 #ifdef FEATUREP_SYNTAX | |
| 2877 if (ch == ']') | |
| 442 | 2878 read_syntax_error ("\"]\" in a list"); |
| 428 | 2879 else if (ch == ')') |
| 442 | 2880 read_syntax_error ("\")\" in a vector"); |
| 428 | 2881 #endif |
| 2882 state = ((conser) (readcharfun, state, len)); | |
| 2883 } | |
| 2884 } | |
| 2885 | |
| 2886 | |
| 2887 struct read_list_state | |
| 2888 { | |
| 2889 Lisp_Object head; | |
| 2890 Lisp_Object tail; | |
| 2891 int length; | |
| 2892 int allow_dotted_lists; | |
| 867 | 2893 Ichar terminator; |
| 428 | 2894 }; |
| 2895 | |
| 2896 static void * | |
| 2286 | 2897 read_list_conser (Lisp_Object readcharfun, void *state, Charcount UNUSED (len)) |
| 428 | 2898 { |
| 2899 struct read_list_state *s = (struct read_list_state *) state; | |
| 2900 Lisp_Object elt; | |
| 2901 | |
| 2902 elt = read1 (readcharfun); | |
| 2903 | |
| 2904 if (CONSP (elt) && UNBOUNDP (XCAR (elt))) | |
| 2905 { | |
| 2906 Lisp_Object tem = elt; | |
| 867 | 2907 Ichar ch; |
| 428 | 2908 |
| 2909 elt = XCDR (elt); | |
| 853 | 2910 free_cons (tem); |
| 428 | 2911 tem = Qnil; |
| 2912 ch = XCHAR (elt); | |
| 2913 #ifdef FEATUREP_SYNTAX | |
| 2914 if (ch == s->terminator) /* deal with #+, #- reader macros */ | |
| 2915 { | |
| 2916 unreadchar (readcharfun, s->terminator); | |
| 2917 goto done; | |
| 2918 } | |
| 2919 else if (ch == ']') | |
| 442 | 2920 read_syntax_error ("']' in a list"); |
| 428 | 2921 else if (ch == ')') |
| 442 | 2922 read_syntax_error ("')' in a vector"); |
| 428 | 2923 else |
| 2924 #endif | |
| 2925 if (ch != '.') | |
| 563 | 2926 signal_error (Qinternal_error, "BUG! Internal reader error", elt); |
| 428 | 2927 else if (!s->allow_dotted_lists) |
| 442 | 2928 read_syntax_error ("\".\" in a vector"); |
| 428 | 2929 else |
| 2930 { | |
| 2931 if (!NILP (s->tail)) | |
| 2932 XCDR (s->tail) = read0 (readcharfun); | |
| 2933 else | |
| 2934 s->head = read0 (readcharfun); | |
| 2935 elt = read1 (readcharfun); | |
| 2936 if (CONSP (elt) && UNBOUNDP (XCAR (elt))) | |
| 2937 { | |
| 2938 ch = XCHAR (XCDR (elt)); | |
| 853 | 2939 free_cons (elt); |
| 428 | 2940 if (ch == s->terminator) |
| 2941 { | |
| 2942 unreadchar (readcharfun, s->terminator); | |
| 2943 goto done; | |
| 2944 } | |
| 2945 } | |
| 442 | 2946 read_syntax_error (". in wrong context"); |
| 428 | 2947 } |
| 2948 } | |
| 2949 | |
| 2950 elt = Fcons (elt, Qnil); | |
| 2951 if (!NILP (s->tail)) | |
| 2952 XCDR (s->tail) = elt; | |
| 2953 else | |
| 2954 s->head = elt; | |
| 2955 s->tail = elt; | |
| 2956 done: | |
| 2957 s->length++; | |
| 2958 return s; | |
| 2959 } | |
| 2960 | |
| 2961 | |
| 814 | 2962 /* allow_dotted_lists means that something like (foo bar . baz) |
| 2963 is acceptable. If -1, means check for starting with defun | |
| 2964 and make structure pure. (not implemented, probably for very | |
| 2965 good reasons) | |
| 2966 | |
| 2967 If check_for_doc_references, look for (#$ . INT) doc references | |
| 2968 in the list and record if load_force_doc_strings is non-zero. | |
| 2969 (Such doc references will be destroyed during the loadup phase | |
| 2970 by replacing with Qzero, because Snarf-documentation will fill | |
| 2971 them in again.) | |
| 2972 | |
| 2973 WARNING: If you set this, you sure as hell better not call | |
| 2974 free_list() on the returned list here. | |
| 2975 */ | |
| 428 | 2976 |
| 2977 static Lisp_Object | |
| 2978 read_list (Lisp_Object readcharfun, | |
| 867 | 2979 Ichar terminator, |
| 428 | 2980 int allow_dotted_lists, |
| 2981 int check_for_doc_references) | |
| 2982 { | |
| 2983 struct read_list_state s; | |
| 2984 struct gcpro gcpro1, gcpro2; | |
| 2985 | |
| 2986 s.head = Qnil; | |
| 2987 s.tail = Qnil; | |
| 2988 s.length = 0; | |
| 2989 s.allow_dotted_lists = allow_dotted_lists; | |
| 2990 s.terminator = terminator; | |
| 2991 GCPRO2 (s.head, s.tail); | |
| 2992 | |
| 2993 sequence_reader (readcharfun, terminator, &s, read_list_conser); | |
| 2994 | |
| 2995 if ((purify_flag || load_force_doc_strings) && check_for_doc_references) | |
| 2996 { | |
| 2997 /* check now for any doc string references and record them | |
| 2998 for later. */ | |
| 2999 Lisp_Object tail; | |
| 3000 | |
| 3001 /* We might be dealing with an imperfect list so don't | |
| 3002 use LIST_LOOP */ | |
| 3003 for (tail = s.head; CONSP (tail); tail = XCDR (tail)) | |
| 3004 { | |
| 3005 Lisp_Object holding_cons = Qnil; | |
| 3006 | |
| 3007 { | |
| 3008 Lisp_Object elem = XCAR (tail); | |
| 3009 /* elem might be (#$ . INT) ... */ | |
| 3010 if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal)) | |
| 3011 holding_cons = tail; | |
| 3012 /* or it might be (quote (#$ . INT)) i.e. | |
| 3013 (quote . ((#$ . INT) . nil)) in the case of | |
| 3014 `autoload' (autoload evaluates its arguments, while | |
| 3015 `defvar', `defun', etc. don't). */ | |
| 3016 if (CONSP (elem) && EQ (XCAR (elem), Qquote) | |
| 3017 && CONSP (XCDR (elem))) | |
| 3018 { | |
| 3019 elem = XCAR (XCDR (elem)); | |
| 3020 if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal)) | |
| 3021 holding_cons = XCDR (XCAR (tail)); | |
| 3022 } | |
| 3023 } | |
| 3024 | |
| 3025 if (CONSP (holding_cons)) | |
| 3026 { | |
| 3027 if (purify_flag) | |
| 3028 { | |
| 3029 if (NILP (Vinternal_doc_file_name)) | |
| 3030 /* We have not yet called Snarf-documentation, so | |
| 3031 assume this file is described in the DOC file | |
| 3032 and Snarf-documentation will fill in the right | |
| 3033 value later. For now, replace the whole list | |
| 3034 with 0. */ | |
| 3035 XCAR (holding_cons) = Qzero; | |
| 3036 else | |
| 3037 /* We have already called Snarf-documentation, so | |
| 3038 make a relative file name for this file, so it | |
| 3039 can be found properly in the installed Lisp | |
| 3040 directory. We don't use Fexpand_file_name | |
| 3041 because that would make the directory absolute | |
| 3042 now. */ | |
| 3043 XCAR (XCAR (holding_cons)) = | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
3044 concat2 (build_ascstring ("../lisp/"), |
| 428 | 3045 Ffile_name_nondirectory |
| 3046 (Vload_file_name_internal)); | |
| 3047 } | |
| 3048 else | |
| 3049 /* Not pure. Just add to Vload_force_doc_string_list, | |
| 3050 and the string will be filled in properly in | |
| 3051 load_force_doc_string_unwind(). */ | |
| 3052 Vload_force_doc_string_list = | |
| 3053 /* We pass the cons that holds the (#$ . INT) so we | |
| 3054 can modify it in-place. */ | |
| 3055 Fcons (holding_cons, Vload_force_doc_string_list); | |
| 3056 } | |
| 3057 } | |
| 3058 } | |
| 3059 | |
| 3060 UNGCPRO; | |
| 3061 return s.head; | |
| 3062 } | |
| 3063 | |
| 3064 static Lisp_Object | |
| 3065 read_vector (Lisp_Object readcharfun, | |
| 867 | 3066 Ichar terminator) |
| 428 | 3067 { |
| 3068 Lisp_Object tem; | |
| 3069 Lisp_Object *p; | |
| 3070 int len; | |
| 3071 int i; | |
| 3072 struct read_list_state s; | |
| 3073 struct gcpro gcpro1, gcpro2; | |
| 3074 | |
| 3075 s.head = Qnil; | |
| 3076 s.tail = Qnil; | |
| 3077 s.length = 0; | |
| 3078 s.allow_dotted_lists = 0; | |
| 3079 GCPRO2 (s.head, s.tail); | |
| 3080 | |
| 3081 sequence_reader (readcharfun, terminator, &s, read_list_conser); | |
| 3082 | |
| 3083 UNGCPRO; | |
| 3084 tem = s.head; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3085 len = XFIXNUM (Flength (tem)); |
| 428 | 3086 |
| 814 | 3087 s.head = make_vector (len, Qnil); |
| 428 | 3088 |
| 3089 for (i = 0, p = &(XVECTOR_DATA (s.head)[0]); | |
| 3090 i < len; | |
| 3091 i++, p++) | |
| 3092 { | |
| 853 | 3093 Lisp_Object otem = tem; |
| 428 | 3094 tem = Fcar (tem); |
| 3095 *p = tem; | |
| 853 | 3096 tem = XCDR (otem); |
| 428 | 3097 free_cons (otem); |
| 3098 } | |
| 3099 return s.head; | |
| 3100 } | |
| 3101 | |
| 3102 static Lisp_Object | |
| 867 | 3103 read_compiled_function (Lisp_Object readcharfun, Ichar terminator) |
| 428 | 3104 { |
| 3105 /* Accept compiled functions at read-time so that we don't | |
| 3106 have to build them at load-time. */ | |
| 3107 Lisp_Object stuff; | |
| 3108 Lisp_Object make_byte_code_args[COMPILED_DOMAIN + 1]; | |
| 3109 struct gcpro gcpro1; | |
| 3110 int len; | |
| 3111 int iii; | |
| 3112 int saw_a_doc_ref = 0; | |
| 3113 | |
| 3114 /* Note: we tell read_list not to search for doc references | |
| 3115 because we need to handle the "doc reference" for the | |
| 3116 instructions and constants differently. */ | |
| 3117 stuff = read_list (readcharfun, terminator, 0, 0); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3118 len = XFIXNUM (Flength (stuff)); |
| 428 | 3119 if (len < COMPILED_STACK_DEPTH + 1 || len > COMPILED_DOMAIN + 1) |
| 3120 return | |
| 442 | 3121 continuable_read_syntax_error ("#[...] used with wrong number of elements"); |
| 428 | 3122 |
| 3123 for (iii = 0; CONSP (stuff); iii++) | |
| 3124 { | |
| 853 | 3125 Lisp_Object victim = stuff; |
| 428 | 3126 make_byte_code_args[iii] = Fcar (stuff); |
| 3127 if ((purify_flag || load_force_doc_strings) | |
| 3128 && CONSP (make_byte_code_args[iii]) | |
| 3129 && EQ (XCAR (make_byte_code_args[iii]), Vload_file_name_internal)) | |
| 3130 { | |
| 3131 if (purify_flag && iii == COMPILED_DOC_STRING) | |
| 3132 { | |
| 3133 /* same as in read_list(). */ | |
| 3134 if (NILP (Vinternal_doc_file_name)) | |
| 3135 make_byte_code_args[iii] = Qzero; | |
| 3136 else | |
| 3137 XCAR (make_byte_code_args[iii]) = | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
3138 concat2 (build_ascstring ("../lisp/"), |
| 428 | 3139 Ffile_name_nondirectory |
| 3140 (Vload_file_name_internal)); | |
| 3141 } | |
| 3142 else | |
| 3143 saw_a_doc_ref = 1; | |
| 3144 } | |
| 3145 stuff = Fcdr (stuff); | |
| 3146 free_cons (victim); | |
| 3147 } | |
| 3148 GCPRO1 (make_byte_code_args[0]); | |
| 3149 gcpro1.nvars = len; | |
| 3150 | |
| 3151 /* v18 or v19 bytecode file. Need to Ebolify. */ | |
| 3152 if (load_byte_code_version < 20 && VECTORP (make_byte_code_args[2])) | |
| 3153 ebolify_bytecode_constants (make_byte_code_args[2]); | |
| 3154 | |
| 3155 /* make-byte-code looks at purify_flag, which should have the same | |
| 3156 * value as our "read-pure" argument */ | |
| 3157 stuff = Fmake_byte_code (len, make_byte_code_args); | |
| 3158 XCOMPILED_FUNCTION (stuff)->flags.ebolified = (load_byte_code_version < 20); | |
| 3159 if (saw_a_doc_ref) | |
| 3160 Vload_force_doc_string_list = Fcons (stuff, Vload_force_doc_string_list); | |
| 3161 UNGCPRO; | |
| 3162 return stuff; | |
| 3163 } | |
| 3164 | |
| 3165 | |
| 3166 | |
| 3167 void | |
| 3168 init_lread (void) | |
| 3169 { | |
| 3170 Vvalues = Qnil; | |
| 3171 | |
| 3172 load_in_progress = 0; | |
| 3173 | |
| 3174 Vload_descriptor_list = Qnil; | |
| 3175 | |
| 3176 /* kludge: locate-file does not work for a null load-path, even if | |
| 3177 the file name is absolute. */ | |
| 3178 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4844
diff
changeset
|
3179 Vload_path = Fcons (build_ascstring (""), Qnil); |
| 428 | 3180 |
| 3181 /* This used to get initialized in init_lread because all streams | |
| 3182 got closed when dumping occurs. This is no longer true -- | |
| 3183 Vread_buffer_stream is a resizing output stream, and there is no | |
| 3184 reason to close it at dump-time. | |
| 3185 | |
| 3186 Vread_buffer_stream is set to Qnil in vars_of_lread, and this | |
| 3187 will initialize it only once, at dump-time. */ | |
| 3188 if (NILP (Vread_buffer_stream)) | |
| 3189 Vread_buffer_stream = make_resizing_buffer_output_stream (); | |
| 3190 | |
| 3191 Vload_force_doc_string_list = Qnil; | |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
3192 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
3193 Vload_file_name_internal = Qnil; |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
3194 Vload_file_name = Qnil; |
| 428 | 3195 } |
| 3196 | |
| 3197 void | |
| 3198 syms_of_lread (void) | |
| 3199 { | |
| 3200 DEFSUBR (Fread); | |
| 3201 DEFSUBR (Fread_from_string); | |
| 3202 DEFSUBR (Fload_internal); | |
| 3203 DEFSUBR (Flocate_file); | |
| 3204 DEFSUBR (Flocate_file_clear_hashing); | |
| 3205 DEFSUBR (Feval_buffer); | |
| 3206 DEFSUBR (Feval_region); | |
| 3207 | |
| 563 | 3208 DEFSYMBOL (Qstandard_input); |
| 3209 DEFSYMBOL (Qread_char); | |
| 3210 DEFSYMBOL (Qload); | |
| 1292 | 3211 DEFSYMBOL (Qload_internal); |
| 563 | 3212 DEFSYMBOL (Qfset); |
| 428 | 3213 |
| 3214 #ifdef LISP_BACKQUOTES | |
| 563 | 3215 DEFSYMBOL (Qbackquote); |
| 428 | 3216 defsymbol (&Qbacktick, "`"); |
| 3217 defsymbol (&Qcomma, ","); | |
| 3218 defsymbol (&Qcomma_at, ",@"); | |
| 3219 defsymbol (&Qcomma_dot, ",."); | |
| 3220 #endif | |
| 3221 | |
| 563 | 3222 DEFSYMBOL (Qexists); |
| 3223 DEFSYMBOL (Qreadable); | |
| 3224 DEFSYMBOL (Qwritable); | |
| 3225 DEFSYMBOL (Qexecutable); | |
| 428 | 3226 } |
| 3227 | |
| 3228 void | |
| 3229 structure_type_create (void) | |
| 3230 { | |
| 3231 the_structure_type_dynarr = Dynarr_new (structure_type); | |
| 3232 } | |
| 3233 | |
| 3234 void | |
| 3235 reinit_vars_of_lread (void) | |
| 3236 { | |
| 3237 Vread_buffer_stream = Qnil; | |
| 3238 staticpro_nodump (&Vread_buffer_stream); | |
| 3239 } | |
| 3240 | |
| 3241 void | |
| 3242 vars_of_lread (void) | |
| 3243 { | |
| 3244 DEFVAR_LISP ("values", &Vvalues /* | |
| 3245 List of values of all expressions which were read, evaluated and printed. | |
| 3246 Order is reverse chronological. | |
| 3247 */ ); | |
| 3248 | |
| 3249 DEFVAR_LISP ("standard-input", &Vstandard_input /* | |
| 3250 Stream for read to get input from. | |
| 3251 See documentation of `read' for possible values. | |
| 3252 */ ); | |
| 3253 Vstandard_input = Qt; | |
| 3254 | |
| 3255 DEFVAR_LISP ("load-path", &Vload_path /* | |
| 3256 *List of directories to search for files to load. | |
| 3257 Each element is a string (directory name) or nil (try default directory). | |
| 3258 | |
| 3259 Note that the elements of this list *may not* begin with "~", so you must | |
| 3260 call `expand-file-name' on them before adding them to this list. | |
| 3261 | |
| 3262 Initialized based on EMACSLOADPATH environment variable, if any, | |
| 3263 otherwise to default specified in by file `paths.h' when XEmacs was built. | |
| 3264 If there were no paths specified in `paths.h', then XEmacs chooses a default | |
| 3265 value for this variable by looking around in the file-system near the | |
| 3266 directory in which the XEmacs executable resides. | |
| 3267 */ ); | |
| 3268 Vload_path = Qnil; | |
| 3269 | |
| 3270 /* xxxDEFVAR_LISP ("dump-load-path", &Vdump_load_path, | |
| 3271 "*Location of lisp files to be used when dumping ONLY."); */ | |
| 3272 | |
| 3273 DEFVAR_BOOL ("load-in-progress", &load_in_progress /* | |
| 3274 Non-nil iff inside of `load'. | |
| 3275 */ ); | |
| 3276 | |
| 2548 | 3277 DEFVAR_LISP ("load-suppress-alist", &Vload_suppress_alist /* |
| 3278 An alist of expressions controlling whether particular files can be loaded. | |
| 3279 Each element looks like (FILENAME EXPR). | |
| 3280 FILENAME should be a full pathname, but without the .el suffix. | |
| 3281 When `load' is run and is about to load the specified file, it evaluates | |
| 3282 the form to determine if the file can be loaded. | |
| 3283 This variable is normally initialized automatically. | |
| 3284 */ ); | |
| 3285 Vload_suppress_alist = Qnil; | |
| 3286 | |
| 428 | 3287 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist /* |
| 3288 An alist of expressions to be evalled when particular files are loaded. | |
| 3289 Each element looks like (FILENAME FORMS...). | |
| 3290 When `load' is run and the file-name argument is FILENAME, | |
| 3291 the FORMS in the corresponding element are executed at the end of loading. | |
| 3292 | |
| 3293 FILENAME must match exactly! Normally FILENAME is the name of a library, | |
| 3294 with no directory specified, since that is how `load' is normally called. | |
| 3295 An error in FORMS does not undo the load, | |
| 3296 but does prevent execution of the rest of the FORMS. | |
| 3297 */ ); | |
| 3298 Vafter_load_alist = Qnil; | |
| 3299 | |
| 3300 DEFVAR_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer /* | |
| 3301 *Whether `load' should check whether the source is newer than the binary. | |
| 3302 If this variable is true, then when a `.elc' file is being loaded and the | |
| 3303 corresponding `.el' is newer, a warning message will be printed. | |
| 3304 */ ); | |
| 1261 | 3305 load_warn_when_source_newer = 1; |
| 428 | 3306 |
| 3307 DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only /* | |
| 3308 *Whether `load' should warn when loading a `.el' file instead of an `.elc'. | |
| 3309 If this variable is true, then when `load' is called with a filename without | |
| 3310 an extension, and the `.elc' version doesn't exist but the `.el' version does, | |
| 3311 then a message will be printed. If an explicit extension is passed to `load', | |
| 3312 no warning will be printed. | |
| 3313 */ ); | |
| 3314 load_warn_when_source_only = 0; | |
| 3315 | |
| 3316 DEFVAR_BOOL ("load-ignore-elc-files", &load_ignore_elc_files /* | |
| 3317 *Whether `load' should ignore `.elc' files when a suffix is not given. | |
| 3318 This is normally used only to bootstrap the `.elc' files when building XEmacs. | |
| 3319 */ ); | |
| 3320 load_ignore_elc_files = 0; | |
| 3321 | |
| 1123 | 3322 DEFVAR_BOOL ("load-ignore-out-of-date-elc-files", |
| 3323 &load_ignore_out_of_date_elc_files /* | |
| 3324 *Whether `load' should ignore out-of-date `.elc' files when no suffix is given. | |
| 3325 This is normally used when compiling packages of elisp files that may have | |
| 3326 complex dependencies. Ignoring all elc files with `load-ignore-elc-files' | |
| 3327 would also be safe, but much slower. | |
| 3328 */ ); | |
|
4955
de64354ffcbf
turn on load-ignore-out-of-date-elc-files by default
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
3329 load_ignore_out_of_date_elc_files = 1; |
| 1123 | 3330 |
| 3331 DEFVAR_BOOL ("load-always-display-messages", | |
| 3332 &load_always_display_messages /* | |
| 3333 *Whether `load' should always display loading messages. | |
| 3334 If this is true, every file loaded will be shown, regardless of the setting | |
| 3335 of the NOMESSAGE parameter, and even when files are loaded indirectly, e.g. | |
| 2857 | 3336 due to `require'. |
| 1123 | 3337 */ ); |
| 3338 load_always_display_messages = 0; | |
| 3339 | |
| 3340 DEFVAR_BOOL ("load-show-full-path-in-messages", | |
| 3341 &load_show_full_path_in_messages /* | |
| 3342 *Whether `load' should show the full path in all loading messages. | |
| 3343 */ ); | |
| 3344 load_show_full_path_in_messages = 0; | |
| 3345 | |
| 428 | 3346 #ifdef LOADHIST |
| 3347 DEFVAR_LISP ("load-history", &Vload_history /* | |
| 3348 Alist mapping source file names to symbols and features. | |
| 3349 Each alist element is a list that starts with a file name, | |
| 3350 except for one element (optional) that starts with nil and describes | |
| 3351 definitions evaluated from buffers not visiting files. | |
| 3352 The remaining elements of each list are symbols defined as functions | |
| 3353 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'. | |
| 3354 */ ); | |
| 3355 Vload_history = Qnil; | |
| 3356 | |
| 3357 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list /* | |
| 3358 Used for internal purposes by `load'. | |
| 3359 */ ); | |
| 3360 Vcurrent_load_list = Qnil; | |
| 3361 #endif | |
| 3362 | |
| 3363 DEFVAR_LISP ("load-file-name", &Vload_file_name /* | |
| 3364 Full name of file being loaded by `load'. | |
| 3365 */ ); | |
| 3366 Vload_file_name = Qnil; | |
| 3367 | |
| 3368 DEFVAR_LISP ("load-read-function", &Vload_read_function /* | |
| 3369 Function used by `load' and `eval-region' for reading expressions. | |
| 3370 The default is nil, which means use the function `read'. | |
| 3371 */ ); | |
| 3372 Vload_read_function = Qnil; | |
| 3373 | |
| 3374 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings /* | |
| 3375 Non-nil means `load' should force-load all dynamic doc strings. | |
| 3376 This is useful when the file being loaded is a temporary copy. | |
| 3377 */ ); | |
| 3378 load_force_doc_strings = 0; | |
| 3379 | |
| 3380 /* See read_escape(). */ | |
| 3381 #if 0 | |
| 3382 /* Used to be named `puke-on-fsf-keys' */ | |
| 3383 DEFVAR_BOOL ("fail-on-bucky-bit-character-escapes", | |
| 3384 &fail_on_bucky_bit_character_escapes /* | |
| 3385 Whether `read' should signal an error when it encounters unsupported | |
| 3386 character escape syntaxes or just read them incorrectly. | |
| 3387 */ ); | |
| 3388 fail_on_bucky_bit_character_escapes = 0; | |
| 3389 #endif | |
| 3390 | |
| 3391 /* This must be initialized in init_lread otherwise it may start out | |
| 3392 with values saved when the image is dumped. */ | |
| 3393 staticpro (&Vload_descriptor_list); | |
| 3394 | |
| 3395 /* Initialized in init_lread. */ | |
| 3396 staticpro (&Vload_force_doc_string_list); | |
| 3397 | |
| 3398 Vload_file_name_internal = Qnil; | |
| 3399 staticpro (&Vload_file_name_internal); | |
| 3400 | |
| 3401 /* So that early-early stuff will work */ | |
| 1292 | 3402 Ffset (Qload, Qload_internal); |
| 428 | 3403 |
| 3404 #ifdef FEATUREP_SYNTAX | |
| 563 | 3405 DEFSYMBOL (Qfeaturep); |
| 771 | 3406 Fprovide (intern ("xemacs")); |
| 428 | 3407 #endif /* FEATUREP_SYNTAX */ |
| 3408 | |
| 3409 #ifdef LISP_BACKQUOTES | |
| 3410 old_backquote_flag = new_backquote_flag = 0; | |
| 3411 #endif | |
| 3412 | |
| 3413 #ifdef I18N3 | |
| 3414 Vfile_domain = Qnil; | |
|
5139
a48ef26d87ee
Clean up prototypes for Lisp variables/symbols. Put decls for them with
Ben Wing <ben@xemacs.org>
parents:
5088
diff
changeset
|
3415 staticpro (&Vfile_domain); |
| 428 | 3416 #endif |
| 3417 | |
| 3418 Vread_objects = Qnil; | |
| 3419 staticpro (&Vread_objects); | |
| 3420 | |
| 3421 Vlocate_file_hash_table = make_lisp_hash_table (200, | |
| 3422 HASH_TABLE_NON_WEAK, | |
|
5211
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3423 #ifdef DEFAULT_FILE_SYSTEM_IGNORE_CASE |
|
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3424 Qequalp |
|
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3425 #else |
|
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3426 Qequal |
|
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3427 #endif |
|
cdca98f2d36f
Move `default-file-system-ignore-case' to C; fix bug in directory hash tables
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3428 ); |
| 428 | 3429 staticpro (&Vlocate_file_hash_table); |
| 3430 #ifdef DEBUG_XEMACS | |
| 3431 symbol_value (XSYMBOL (intern ("Vlocate-file-hash-table"))) | |
| 3432 = Vlocate_file_hash_table; | |
| 3433 #endif | |
| 3434 } |