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