Mercurial > hg > xemacs-beta
annotate src/lread.c @ 4844:91b3d00e717f
Various cleanups for Dynarr code, from Unicode-internal ws
dynarr.c: Add comment explaining Dynarr_largest() use.
dynarr.c: In Dynarr_insert_many(), don't call Dynarr_resize() unless we
actually need to resize, and note that an assert() that we are
inserting at or below the current end could be wrong if code
wants to access stuff between `len' and `largest'.
dynarr.c: Don't just Dynarr_resize() to the right size; instead use
Dynarr_reset() then Dynarr_add_many(), so that the 'len' and
'largest' and such get set properly.
dynarr.c, faces.c, gutter.c, lisp.h, lread.c, lrecord.h, redisplay-output.c, redisplay.c: Rename Dynarr member 'cur' to 'len' since it's the length of
the dynarr, not really a pointer to a "current insertion point".
Use type_checking_assert() instead of just assert() in some places.
Add additional assertions (Dynarr_verify*()) to check that we're
being given positions within range. Use them in Dynarr_at,
Dynarr_atp, etc. New Dynarr_atp_allow_end() for retrieving a
pointer to a position that might be the element past the last one.
New Dynarr_past_lastp() to retrieve a pointer to the position
past the last one, using Dynarr_atp_allow_end(). Change code
appropriately to use it.
Rename Dynarr_end() to Dynarr_lastp() (pointer to the last
element) for clarity, and change code appropriately to use it.
Change code appropriately to use Dynarr_begin().
Rewrite Dynarr_add_many(). New version can accept a NULL pointer
to mean "reserve space but don't put anything in it". Used by
stack_like_malloc().
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Wed, 13 Jan 2010 04:07:42 -0600 |
parents | 8f1ee2d15784 |
children | 17362f371cc2 19a72041c5ed |
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); | |
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
375 val = IGNORE_MULTIPLE_VALUES (Feval (XCDR (acons))); |
2567 | 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 | |
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
714 LISP_READONLY (found) = 1; |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
715 |
428 | 716 { |
717 /* Lisp_Object's must be malloc'ed, not stack-allocated */ | |
718 Lisp_Object lispstream = Qnil; | |
442 | 719 const int block_size = 8192; |
428 | 720 struct gcpro ngcpro1; |
721 | |
722 NGCPRO1 (lispstream); | |
723 lispstream = make_filedesc_input_stream (fd, 0, -1, LSTR_CLOSING); | |
724 /* 64K is used for normal files; 8K should be OK here because Lisp | |
725 files aren't really all that big. */ | |
726 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED, | |
727 block_size); | |
771 | 728 lispstream = make_coding_input_stream |
729 (XLSTREAM (lispstream), get_coding_system_for_text_file (codesys, 1), | |
800 | 730 CODING_DECODE, 0); |
428 | 731 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED, |
732 block_size); | |
733 /* NOTE: Order of these is very important. Don't rearrange them. */ | |
853 | 734 internal_bind_int (&load_in_progress, 1 + load_in_progress); |
428 | 735 record_unwind_protect (load_unwind, lispstream); |
853 | 736 internal_bind_lisp_object (&Vload_descriptor_list, |
737 Fcons (make_int (fd), Vload_descriptor_list)); | |
738 internal_bind_lisp_object (&Vload_file_name_internal, found); | |
739 /* this is not a simple internal_bind. */ | |
428 | 740 record_unwind_protect (load_force_doc_string_unwind, |
741 Vload_force_doc_string_list); | |
853 | 742 Vload_force_doc_string_list = Qnil; |
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
743 /* load-file-name is not read-only to Lisp. */ |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
744 internal_bind_lisp_object (&Vload_file_name, Fcopy_sequence(found)); |
428 | 745 #ifdef I18N3 |
853 | 746 /* set it to nil; a call to #'domain will set it. */ |
747 internal_bind_lisp_object (&Vfile_domain, Qnil); | |
428 | 748 #endif |
749 | |
4448
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
750 /* Is there a #!? If so, read it, and unread ;!. |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
751 |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
752 GNU implement this by treating any #! anywhere in the source text as |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
753 commenting out the whole line. */ |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
754 { |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
755 char shebangp[2]; |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
756 int num_read; |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
757 |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
758 num_read = Lstream_read (XLSTREAM (lispstream), shebangp, |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
759 sizeof(shebangp)); |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
760 if (sizeof(shebangp) == num_read |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
761 && 0 == strncmp("#!", shebangp, sizeof(shebangp))) |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
762 { |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
763 shebangp[0] = ';'; |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
764 } |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
765 |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
766 Lstream_unread (XLSTREAM (lispstream), shebangp, num_read); |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
767 } |
fd8a9a4d81d9
Support #!, to allow XEmacs to be called as a script interpreter.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
768 |
428 | 769 /* Now determine what sort of ELC file we're reading in. */ |
853 | 770 internal_bind_int (&load_byte_code_version, load_byte_code_version); |
428 | 771 if (reading_elc) |
772 { | |
773 char elc_header[8]; | |
774 int num_read; | |
775 | |
776 num_read = Lstream_read (XLSTREAM (lispstream), elc_header, 8); | |
777 if (num_read < 8 | |
778 || strncmp (elc_header, ";ELC", 4)) | |
779 { | |
780 /* Huh? Probably not a valid ELC file. */ | |
781 load_byte_code_version = 100; /* no Ebolification needed */ | |
782 Lstream_unread (XLSTREAM (lispstream), elc_header, num_read); | |
783 } | |
784 else | |
785 load_byte_code_version = elc_header[4]; | |
786 } | |
787 else | |
788 load_byte_code_version = 100; /* no Ebolification needed */ | |
789 | |
790 readevalloop (lispstream, file, Feval, 0); | |
791 if (!NILP (used_codesys)) | |
792 Fset (used_codesys, | |
793 XCODING_SYSTEM_NAME | |
771 | 794 (coding_stream_detected_coding_system (XLSTREAM (lispstream)))); |
795 unbind_to (speccount); | |
428 | 796 |
797 NUNGCPRO; | |
798 } | |
799 | |
800 { | |
801 Lisp_Object tem; | |
802 /* #### Disgusting kludge */ | |
803 /* Run any load-hooks for this file. */ | |
804 /* #### An even more disgusting kludge. There is horrible code */ | |
805 /* that is relying on the fact that dumped lisp files are found */ | |
806 /* via `load-path' search. */ | |
807 Lisp_Object name = file; | |
808 | |
1123 | 809 if (!NILP (Ffile_name_absolute_p (file))) |
810 name = Ffile_name_nondirectory (file); | |
428 | 811 |
1261 | 812 tem = Fassoc (name, Vafter_load_alist); |
428 | 813 if (!NILP (tem)) |
814 { | |
815 struct gcpro ngcpro1; | |
816 | |
817 NGCPRO1 (tem); | |
818 /* Use eval so that errors give a semi-meaningful backtrace. --Stig */ | |
819 tem = Fcons (Qprogn, Fcdr (tem)); | |
820 Feval (tem); | |
821 NUNGCPRO; | |
822 } | |
823 } | |
824 | |
825 if (!noninteractive) | |
826 PRINT_LOADING_MESSAGE ("done"); | |
827 | |
1292 | 828 retval = Qt; |
829 done: | |
830 PROFILE_RECORD_EXITING_SECTION (Qload_internal); | |
428 | 831 UNGCPRO; |
1292 | 832 return retval; |
428 | 833 } |
834 | |
835 | |
836 /* ------------------------------- */ | |
837 /* locate_file */ | |
838 /* ------------------------------- */ | |
839 | |
840 static int | |
841 decode_mode_1 (Lisp_Object mode) | |
842 { | |
843 if (EQ (mode, Qexists)) | |
844 return F_OK; | |
845 else if (EQ (mode, Qexecutable)) | |
846 return X_OK; | |
847 else if (EQ (mode, Qwritable)) | |
848 return W_OK; | |
849 else if (EQ (mode, Qreadable)) | |
850 return R_OK; | |
851 else if (INTP (mode)) | |
852 { | |
853 check_int_range (XINT (mode), 0, 7); | |
854 return XINT (mode); | |
855 } | |
856 else | |
563 | 857 invalid_argument ("Invalid value", mode); |
428 | 858 return 0; /* unreached */ |
859 } | |
860 | |
861 static int | |
862 decode_mode (Lisp_Object mode) | |
863 { | |
864 if (NILP (mode)) | |
865 return R_OK; | |
866 else if (CONSP (mode)) | |
867 { | |
868 int mask = 0; | |
2367 | 869 EXTERNAL_LIST_LOOP_2 (elt, mode) |
870 mask |= decode_mode_1 (elt); | |
428 | 871 return mask; |
872 } | |
873 else | |
874 return decode_mode_1 (mode); | |
875 } | |
876 | |
877 DEFUN ("locate-file", Flocate_file, 2, 4, 0, /* | |
878 Search for FILENAME through PATH-LIST. | |
879 | |
880 If SUFFIXES is non-nil, it should be a list of suffixes to append to | |
881 file name when searching. | |
882 | |
883 If MODE is non-nil, it should be a symbol or a list of symbol representing | |
884 requirements. Allowed symbols are `exists', `executable', `writable', and | |
885 `readable'. If MODE is nil, it defaults to `readable'. | |
886 | |
2548 | 887 Filenames are checked against `load-suppress-alist' to determine if they |
888 should be ignored. | |
889 | |
428 | 890 `locate-file' keeps hash tables of the directories it searches through, |
891 in order to speed things up. It tries valiantly to not get confused in | |
892 the face of a changing and unpredictable environment, but can occasionally | |
893 get tripped up. In this case, you will have to call | |
894 `locate-file-clear-hashing' to get it back on track. See that function | |
895 for details. | |
896 */ | |
897 (filename, path_list, suffixes, mode)) | |
898 { | |
899 /* This function can GC */ | |
900 Lisp_Object tp; | |
901 | |
902 CHECK_STRING (filename); | |
903 | |
904 if (LISTP (suffixes)) | |
905 { | |
2367 | 906 EXTERNAL_LIST_LOOP_2 (elt, suffixes) |
907 CHECK_STRING (elt); | |
428 | 908 } |
909 else | |
910 CHECK_STRING (suffixes); | |
911 | |
912 locate_file (path_list, filename, suffixes, &tp, decode_mode (mode)); | |
913 return tp; | |
914 } | |
915 | |
916 /* Recalculate the hash table for the given string. DIRECTORY should | |
917 better have been through Fexpand_file_name() by now. */ | |
918 | |
919 static Lisp_Object | |
920 locate_file_refresh_hashing (Lisp_Object directory) | |
921 { | |
922 Lisp_Object hash = | |
771 | 923 make_directory_hash_table (XSTRING_DATA (directory)); |
428 | 924 |
925 if (!NILP (hash)) | |
926 Fputhash (directory, hash, Vlocate_file_hash_table); | |
927 return hash; | |
928 } | |
929 | |
930 /* find the hash table for the given directory, recalculating if necessary */ | |
931 | |
932 static Lisp_Object | |
933 locate_file_find_directory_hash_table (Lisp_Object directory) | |
934 { | |
935 Lisp_Object hash = Fgethash (directory, Vlocate_file_hash_table, Qnil); | |
936 if (NILP (hash)) | |
937 return locate_file_refresh_hashing (directory); | |
938 else | |
939 return hash; | |
940 } | |
941 | |
942 /* The SUFFIXES argument in any of the locate_file* functions can be | |
943 nil, a list, or a string (for backward compatibility), with the | |
944 following semantics: | |
945 | |
946 a) nil - no suffix, just search for file name intact | |
947 (semantically different from "empty suffix list", which | |
948 would be meaningless.) | |
949 b) list - list of suffixes to append to file name. Each of these | |
950 must be a string. | |
951 c) string - colon-separated suffixes to append to file name (backward | |
952 compatibility). | |
953 | |
954 All of this got hairy, so I decided to use a mapper. Calling a | |
955 function for each suffix shouldn't slow things down, since | |
956 locate_file is rarely called with enough suffixes for funcalls to | |
957 make any difference. */ | |
958 | |
959 /* Map FUN over SUFFIXES, as described above. FUN will be called with a | |
960 char * containing the current file name, and ARG. Mapping stops when | |
961 FUN returns non-zero. */ | |
962 static void | |
963 locate_file_map_suffixes (Lisp_Object filename, Lisp_Object suffixes, | |
867 | 964 int (*fun) (Ibyte *, void *), |
428 | 965 void *arg) |
966 { | |
967 /* This function can GC */ | |
867 | 968 Ibyte *fn; |
428 | 969 int fn_len, max; |
970 | |
971 /* Calculate maximum size of any filename made from | |
972 this path element/specified file name and any possible suffix. */ | |
973 if (CONSP (suffixes)) | |
974 { | |
975 /* We must traverse the list, so why not do it right. */ | |
976 Lisp_Object tail; | |
977 max = 0; | |
978 LIST_LOOP (tail, suffixes) | |
979 { | |
980 if (XSTRING_LENGTH (XCAR (tail)) > max) | |
981 max = XSTRING_LENGTH (XCAR (tail)); | |
982 } | |
983 } | |
984 else if (NILP (suffixes)) | |
985 max = 0; | |
986 else | |
987 /* Just take the easy way out */ | |
988 max = XSTRING_LENGTH (suffixes); | |
989 | |
990 fn_len = XSTRING_LENGTH (filename); | |
2367 | 991 fn = alloca_ibytes (max + fn_len + 1); |
771 | 992 memcpy (fn, XSTRING_DATA (filename), fn_len); |
428 | 993 |
994 /* Loop over suffixes. */ | |
995 if (!STRINGP (suffixes)) | |
996 { | |
997 if (NILP (suffixes)) | |
998 { | |
999 /* Case a) discussed in the comment above. */ | |
1000 fn[fn_len] = 0; | |
1001 if ((*fun) (fn, arg)) | |
1002 return; | |
1003 } | |
1004 else | |
1005 { | |
1006 /* Case b) */ | |
1007 Lisp_Object tail; | |
1008 LIST_LOOP (tail, suffixes) | |
1009 { | |
1010 memcpy (fn + fn_len, XSTRING_DATA (XCAR (tail)), | |
1011 XSTRING_LENGTH (XCAR (tail))); | |
1012 fn[fn_len + XSTRING_LENGTH (XCAR (tail))] = 0; | |
1013 if ((*fun) (fn, arg)) | |
1014 return; | |
1015 } | |
1016 } | |
1017 } | |
1018 else | |
1019 { | |
1020 /* Case c) */ | |
867 | 1021 const Ibyte *nsuffix = XSTRING_DATA (suffixes); |
428 | 1022 |
1023 while (1) | |
1024 { | |
867 | 1025 Ibyte *esuffix = qxestrchr (nsuffix, ':'); |
771 | 1026 Bytecount lsuffix = esuffix ? esuffix - nsuffix : |
1027 qxestrlen (nsuffix); | |
428 | 1028 |
1029 /* Concatenate path element/specified name with the suffix. */ | |
771 | 1030 qxestrncpy (fn + fn_len, nsuffix, lsuffix); |
428 | 1031 fn[fn_len + lsuffix] = 0; |
1032 | |
1033 if ((*fun) (fn, arg)) | |
1034 return; | |
1035 | |
1036 /* Advance to next suffix. */ | |
1037 if (esuffix == 0) | |
1038 break; | |
1039 nsuffix += lsuffix + 1; | |
1040 } | |
1041 } | |
1042 } | |
1043 | |
771 | 1044 struct locate_file_in_directory_mapper_closure |
1045 { | |
428 | 1046 int fd; |
1047 Lisp_Object *storeptr; | |
1048 int mode; | |
1049 }; | |
1050 | |
1123 | 1051 /* open() or access() a file to be returned by locate_file(). if |
1052 ACCESS_MODE >= 0, do an access() with that mode, else open(). Does | |
1053 various magic, e.g. opening the file read-only and binary and setting | |
1054 the close-on-exec flag on the file. */ | |
1055 | |
1056 static int | |
1057 locate_file_open_or_access_file (Ibyte *fn, int access_mode) | |
1058 { | |
1059 int val; | |
1060 | |
1061 /* Check that we can access or open it. */ | |
1062 if (access_mode >= 0) | |
1063 val = qxe_access (fn, access_mode); | |
1064 else | |
1065 { | |
1066 val = qxe_open (fn, O_RDONLY | OPEN_BINARY, 0); | |
1067 | |
1068 #ifndef WIN32_NATIVE | |
1069 if (val >= 0) | |
1070 /* If we actually opened the file, set close-on-exec flag | |
1071 on the new descriptor so that subprocesses can't whack | |
1072 at it. */ | |
1073 (void) fcntl (val, F_SETFD, FD_CLOEXEC); | |
1074 #endif | |
1075 } | |
1076 | |
1077 return val; | |
1078 } | |
1079 | |
428 | 1080 static int |
867 | 1081 locate_file_in_directory_mapper (Ibyte *fn, void *arg) |
428 | 1082 { |
1083 struct locate_file_in_directory_mapper_closure *closure = | |
771 | 1084 (struct locate_file_in_directory_mapper_closure *) arg; |
428 | 1085 struct stat st; |
1086 | |
1087 /* Ignore file if it's a directory. */ | |
771 | 1088 if (qxe_stat (fn, &st) >= 0 |
428 | 1089 && (st.st_mode & S_IFMT) != S_IFDIR) |
1090 { | |
1091 /* Check that we can access or open it. */ | |
1123 | 1092 closure->fd = locate_file_open_or_access_file (fn, closure->mode); |
428 | 1093 |
1094 if (closure->fd >= 0) | |
1095 { | |
2548 | 1096 if (!check_if_suppressed (fn, Qnil)) |
1097 { | |
1098 /* We succeeded; return this descriptor and filename. */ | |
1099 if (closure->storeptr) | |
1100 *closure->storeptr = build_intstring (fn); | |
1101 | |
1102 return 1; | |
1103 } | |
428 | 1104 } |
1105 } | |
1106 /* Keep mapping. */ | |
1107 return 0; | |
1108 } | |
1109 | |
1110 | |
1111 /* look for STR in PATH, optionally adding SUFFIXES. DIRECTORY need | |
1112 not have been expanded. */ | |
1113 | |
1114 static int | |
1115 locate_file_in_directory (Lisp_Object directory, Lisp_Object str, | |
1116 Lisp_Object suffixes, Lisp_Object *storeptr, | |
1117 int mode) | |
1118 { | |
1119 /* This function can GC */ | |
1120 struct locate_file_in_directory_mapper_closure closure; | |
1121 Lisp_Object filename = Qnil; | |
1122 struct gcpro gcpro1, gcpro2, gcpro3; | |
1123 | |
1124 GCPRO3 (directory, str, filename); | |
1125 | |
1126 filename = Fexpand_file_name (str, directory); | |
1127 if (NILP (filename) || NILP (Ffile_name_absolute_p (filename))) | |
1128 /* If there are non-absolute elts in PATH (eg ".") */ | |
1129 /* Of course, this could conceivably lose if luser sets | |
1130 default-directory to be something non-absolute ... */ | |
1131 { | |
1132 if (NILP (filename)) | |
1133 /* NIL means current directory */ | |
1134 filename = current_buffer->directory; | |
1135 else | |
1136 filename = Fexpand_file_name (filename, | |
1137 current_buffer->directory); | |
1138 if (NILP (Ffile_name_absolute_p (filename))) | |
1139 { | |
1140 /* Give up on this directory! */ | |
1141 UNGCPRO; | |
1142 return -1; | |
1143 } | |
1144 } | |
1145 | |
1146 closure.fd = -1; | |
1147 closure.storeptr = storeptr; | |
1148 closure.mode = mode; | |
1149 | |
771 | 1150 locate_file_map_suffixes (filename, suffixes, |
1151 locate_file_in_directory_mapper, | |
428 | 1152 &closure); |
1153 | |
1154 UNGCPRO; | |
1155 return closure.fd; | |
1156 } | |
1157 | |
1158 /* do the same as locate_file() but don't use any hash tables. */ | |
1159 | |
1160 static int | |
1161 locate_file_without_hash (Lisp_Object path, Lisp_Object str, | |
1162 Lisp_Object suffixes, Lisp_Object *storeptr, | |
1163 int mode) | |
1164 { | |
1165 /* This function can GC */ | |
1166 int absolute = !NILP (Ffile_name_absolute_p (str)); | |
1167 | |
2367 | 1168 EXTERNAL_LIST_LOOP_2 (elt, path) |
428 | 1169 { |
2367 | 1170 int val = locate_file_in_directory (elt, str, suffixes, storeptr, |
428 | 1171 mode); |
1172 if (val >= 0) | |
1173 return val; | |
1174 if (absolute) | |
1175 break; | |
1176 } | |
1177 return -1; | |
1178 } | |
1179 | |
1180 static int | |
867 | 1181 locate_file_construct_suffixed_files_mapper (Ibyte *fn, void *arg) |
428 | 1182 { |
771 | 1183 Lisp_Object *tail = (Lisp_Object *) arg; |
1184 *tail = Fcons (build_intstring (fn), *tail); | |
428 | 1185 return 0; |
1186 } | |
1187 | |
1188 /* Construct a list of all files to search for. | |
1189 It makes sense to have this despite locate_file_map_suffixes() | |
1190 because we need Lisp strings to access the hash-table, and it would | |
1191 be inefficient to create them on the fly, again and again for each | |
1192 path component. See locate_file(). */ | |
1193 | |
1194 static Lisp_Object | |
1195 locate_file_construct_suffixed_files (Lisp_Object filename, | |
1196 Lisp_Object suffixes) | |
1197 { | |
1198 Lisp_Object tail = Qnil; | |
1199 struct gcpro gcpro1; | |
1200 GCPRO1 (tail); | |
1201 | |
1202 locate_file_map_suffixes (filename, suffixes, | |
1203 locate_file_construct_suffixed_files_mapper, | |
1204 &tail); | |
1205 | |
1206 UNGCPRO; | |
1207 return Fnreverse (tail); | |
1208 } | |
1209 | |
1210 DEFUN ("locate-file-clear-hashing", Flocate_file_clear_hashing, 1, 1, 0, /* | |
1211 Clear the hash records for the specified list of directories. | |
1212 `locate-file' uses a hashing scheme to speed lookup, and will correctly | |
1213 track the following environmental changes: | |
1214 | |
1215 -- changes of any sort to the list of directories to be searched. | |
1216 -- addition and deletion of non-shadowing files (see below) from the | |
1217 directories in the list. | |
1218 -- byte-compilation of a .el file into a .elc file. | |
1219 | |
1220 `locate-file' will primarily get confused if you add a file that shadows | |
1221 \(i.e. has the same name as) another file further down in the directory list. | |
1222 In this case, you must call `locate-file-clear-hashing'. | |
1223 | |
1224 If PATH is t, it means to fully clear all the accumulated hashes. This | |
1225 can be used if the internal tables grow too large, or when dumping. | |
1226 */ | |
1227 (path)) | |
1228 { | |
1229 if (EQ (path, Qt)) | |
1230 Fclrhash (Vlocate_file_hash_table); | |
1231 else | |
1232 { | |
2367 | 1233 EXTERNAL_LIST_LOOP_2 (elt, path) |
428 | 1234 { |
2367 | 1235 Lisp_Object pathel = Fexpand_file_name (elt, Qnil); |
428 | 1236 Fremhash (pathel, Vlocate_file_hash_table); |
1237 } | |
1238 } | |
1239 return Qnil; | |
1240 } | |
1241 | |
1242 /* Search for a file whose name is STR, looking in directories | |
1243 in the Lisp list PATH, and trying suffixes from SUFFIXES. | |
1244 SUFFIXES is a list of possible suffixes, or (for backward | |
1245 compatibility) a string containing possible suffixes separated by | |
1246 colons. | |
1247 On success, returns a file descriptor. On failure, returns -1. | |
1248 | |
1249 MODE nonnegative means don't open the files, | |
1250 just look for one for which access(file,MODE) succeeds. In this case, | |
951 | 1251 returns a nonnegative value on success. On failure, returns -1. |
428 | 1252 |
2548 | 1253 If STOREPTR is non-nil, it points to a slot where the name of |
428 | 1254 the file actually found should be stored as a Lisp string. |
1255 Nil is stored there on failure. | |
1256 | |
1257 Called openp() in FSFmacs. */ | |
1258 | |
1259 int | |
1260 locate_file (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, | |
1261 Lisp_Object *storeptr, int mode) | |
1262 { | |
1263 /* This function can GC */ | |
1264 Lisp_Object suffixtab = Qnil; | |
2367 | 1265 Lisp_Object pathel_expanded; |
428 | 1266 int val; |
1267 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
1268 | |
1269 if (storeptr) | |
1270 *storeptr = Qnil; | |
1271 | |
1272 /* Is it really necessary to gcpro path and str? It shouldn't be | |
1273 unless some caller has fucked up. There are known instances that | |
1274 call us with build_string("foo:bar") as SUFFIXES, though. */ | |
1275 GCPRO4 (path, str, suffixes, suffixtab); | |
1276 | |
1277 /* if this filename has directory components, it's too complicated | |
1278 to try and use the hash tables. */ | |
1279 if (!NILP (Ffile_name_directory (str))) | |
1280 { | |
1281 val = locate_file_without_hash (path, str, suffixes, storeptr, mode); | |
1282 UNGCPRO; | |
1283 return val; | |
1284 } | |
1285 | |
1286 suffixtab = locate_file_construct_suffixed_files (str, suffixes); | |
1287 | |
2367 | 1288 { |
1289 EXTERNAL_LIST_LOOP_2 (pathel, path) | |
1290 { | |
1291 Lisp_Object hash_table; | |
1292 int found = 0; | |
1293 | |
1294 /* If this path element is relative, we have to look by hand. */ | |
1295 if (NILP (pathel) || NILP (Ffile_name_absolute_p (pathel))) | |
1296 { | |
1297 val = locate_file_in_directory (pathel, str, suffixes, storeptr, | |
1298 mode); | |
1299 if (val >= 0) | |
428 | 1300 { |
2367 | 1301 UNGCPRO; |
1302 return val; | |
428 | 1303 } |
2367 | 1304 continue; |
1305 } | |
1306 | |
1307 pathel_expanded = Fexpand_file_name (pathel, Qnil); | |
1308 hash_table = locate_file_find_directory_hash_table (pathel_expanded); | |
1309 | |
1310 if (!NILP (hash_table)) | |
1311 { | |
1312 /* Loop over suffixes. */ | |
1313 LIST_LOOP_2 (elt, suffixtab) | |
1314 if (!NILP (Fgethash (elt, hash_table, Qnil))) | |
1315 { | |
1316 found = 1; | |
1317 break; | |
1318 } | |
1319 } | |
1320 | |
1321 if (found) | |
1322 { | |
1323 /* This is a likely candidate. Look by hand in this directory | |
1324 so we don't get thrown off if someone byte-compiles a file. */ | |
1325 val = locate_file_in_directory (pathel, str, suffixes, storeptr, | |
1326 mode); | |
1327 if (val >= 0) | |
1328 { | |
1329 UNGCPRO; | |
1330 return val; | |
1331 } | |
1332 | |
1333 /* Hmm ... the file isn't actually there. (Or possibly it's | |
1334 a directory ...) So refresh our hashing. */ | |
1335 locate_file_refresh_hashing (pathel_expanded); | |
1336 } | |
1337 } | |
428 | 1338 } |
1339 | |
1340 /* File is probably not there, but check the hard way just in case. */ | |
1341 val = locate_file_without_hash (path, str, suffixes, storeptr, mode); | |
1342 if (val >= 0) | |
1343 { | |
1344 /* Sneaky user added a file without telling us. */ | |
1345 Flocate_file_clear_hashing (path); | |
1346 } | |
1347 | |
1348 UNGCPRO; | |
1349 return val; | |
1350 } | |
1351 | |
1352 | |
1353 #ifdef LOADHIST | |
1354 | |
1355 /* Merge the list we've accumulated of globals from the current input source | |
1356 into the load_history variable. The details depend on whether | |
1357 the source has an associated file name or not. */ | |
1358 | |
1359 static void | |
1360 build_load_history (int loading, Lisp_Object source) | |
1361 { | |
1362 REGISTER Lisp_Object tail, prev, newelt; | |
1363 REGISTER Lisp_Object tem, tem2; | |
1364 int foundit; | |
1365 | |
1366 #if !defined(LOADHIST_DUMPED) | |
1367 /* Don't bother recording anything for preloaded files. */ | |
1368 if (purify_flag) | |
1369 return; | |
1370 #endif | |
1371 | |
1372 tail = Vload_history; | |
1373 prev = Qnil; | |
1374 foundit = 0; | |
1375 while (!NILP (tail)) | |
1376 { | |
1377 tem = Fcar (tail); | |
1378 | |
1379 /* Find the feature's previous assoc list... */ | |
1380 if (internal_equal (source, Fcar (tem), 0)) | |
1381 { | |
1382 foundit = 1; | |
1383 | |
1384 /* If we're loading, remove it. */ | |
1385 if (loading) | |
1386 { | |
1387 if (NILP (prev)) | |
1388 Vload_history = Fcdr (tail); | |
1389 else | |
1390 Fsetcdr (prev, Fcdr (tail)); | |
1391 } | |
1392 | |
1393 /* Otherwise, cons on new symbols that are not already members. */ | |
1394 else | |
1395 { | |
1396 tem2 = Vcurrent_load_list; | |
1397 | |
1398 while (CONSP (tem2)) | |
1399 { | |
1400 newelt = XCAR (tem2); | |
1401 | |
1402 if (NILP (Fmemq (newelt, tem))) | |
1403 Fsetcar (tail, Fcons (Fcar (tem), | |
1404 Fcons (newelt, Fcdr (tem)))); | |
1405 | |
1406 tem2 = XCDR (tem2); | |
1407 QUIT; | |
1408 } | |
1409 } | |
1410 } | |
1411 else | |
1412 prev = tail; | |
1413 tail = Fcdr (tail); | |
1414 QUIT; | |
1415 } | |
1416 | |
1417 /* If we're loading, cons the new assoc onto the front of load-history, | |
1418 the most-recently-loaded position. Also do this if we didn't find | |
1419 an existing member for the current source. */ | |
1420 if (loading || !foundit) | |
1421 Vload_history = Fcons (Fnreverse (Vcurrent_load_list), | |
1422 Vload_history); | |
1423 } | |
1424 | |
1425 #else /* !LOADHIST */ | |
1426 #define build_load_history(x,y) | |
1427 #endif /* !LOADHIST */ | |
1428 | |
1429 | |
1430 static void | |
1431 readevalloop (Lisp_Object readcharfun, | |
1432 Lisp_Object sourcename, | |
1433 Lisp_Object (*evalfun) (Lisp_Object), | |
1434 int printflag) | |
1435 { | |
1436 /* This function can GC */ | |
867 | 1437 REGISTER Ichar c; |
1849 | 1438 Lisp_Object val = Qnil; |
428 | 1439 int speccount = specpdl_depth (); |
1440 struct gcpro gcpro1, gcpro2; | |
1441 struct buffer *b = 0; | |
1442 | |
1443 if (BUFFERP (readcharfun)) | |
1444 b = XBUFFER (readcharfun); | |
1445 else if (MARKERP (readcharfun)) | |
1446 b = XMARKER (readcharfun)->buffer; | |
1447 | |
1448 /* Don't do this. It is not necessary, and it needlessly exposes | |
1449 READCHARFUN (which can be a stream) to Lisp. --hniksic */ | |
1450 /*specbind (Qstandard_input, readcharfun);*/ | |
1451 | |
2548 | 1452 internal_bind_lisp_object (&Vcurrent_load_list, Qnil); |
428 | 1453 |
1454 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
1455 Vcurrent_compiled_function_annotation = Qnil; | |
1456 #endif | |
1457 GCPRO2 (val, sourcename); | |
1458 | |
1459 LOADHIST_ATTACH (sourcename); | |
1460 | |
1461 while (1) | |
1462 { | |
1463 QUIT; | |
1464 | |
1465 if (b != 0 && !BUFFER_LIVE_P (b)) | |
563 | 1466 invalid_operation ("Reading from killed buffer", Qunbound); |
428 | 1467 |
1468 c = readchar (readcharfun); | |
1469 if (c == ';') | |
1470 { | |
1471 /* Skip comment */ | |
1472 while ((c = readchar (readcharfun)) != '\n' && c != -1) | |
1473 QUIT; | |
1474 continue; | |
1475 } | |
1476 if (c < 0) | |
1477 break; | |
1478 | |
1479 /* Ignore whitespace here, so we can detect eof. */ | |
1480 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r') | |
1481 continue; | |
1482 | |
814 | 1483 unreadchar (readcharfun, c); |
1484 Vread_objects = Qnil; | |
1485 if (NILP (Vload_read_function)) | |
1486 val = read0 (readcharfun); | |
428 | 1487 else |
814 | 1488 val = call1 (Vload_read_function, readcharfun); |
428 | 1489 val = (*evalfun) (val); |
1490 if (printflag) | |
1491 { | |
1492 Vvalues = Fcons (val, Vvalues); | |
1493 if (EQ (Vstandard_output, Qt)) | |
1494 Fprin1 (val, Qnil); | |
1495 else | |
1496 Fprint (val, Qnil); | |
1497 } | |
1498 } | |
1499 | |
1500 build_load_history (LSTREAMP (readcharfun) || | |
1501 /* This looks weird, but it's what's in FSFmacs */ | |
1502 (b ? BUF_NARROWED (b) : BUF_NARROWED (current_buffer)), | |
1503 sourcename); | |
1504 UNGCPRO; | |
1505 | |
771 | 1506 unbind_to (speccount); |
428 | 1507 } |
1508 | |
1509 DEFUN ("eval-buffer", Feval_buffer, 0, 2, "bBuffer: ", /* | |
1510 Execute BUFFER as Lisp code. | |
1511 Programs can pass two arguments, BUFFER and PRINTFLAG. | |
1512 BUFFER is the buffer to evaluate (nil means use current buffer). | |
1513 PRINTFLAG controls printing of output: | |
444 | 1514 nil means discard it; anything else is a stream for printing. |
428 | 1515 |
1516 If there is no error, point does not move. If there is an error, | |
1517 point remains at the end of the last character read from the buffer. | |
1518 */ | |
444 | 1519 (buffer, printflag)) |
428 | 1520 { |
1521 /* This function can GC */ | |
1522 int speccount = specpdl_depth (); | |
1523 Lisp_Object tem, buf; | |
1524 | |
444 | 1525 if (NILP (buffer)) |
428 | 1526 buf = Fcurrent_buffer (); |
1527 else | |
444 | 1528 buf = Fget_buffer (buffer); |
428 | 1529 if (NILP (buf)) |
563 | 1530 invalid_argument ("No such buffer", Qunbound); |
428 | 1531 |
1532 if (NILP (printflag)) | |
1533 tem = Qsymbolp; /* #### #@[]*&$#*[& SI:NULL-STREAM */ | |
1534 else | |
1535 tem = printflag; | |
1536 specbind (Qstandard_output, tem); | |
1537 record_unwind_protect (save_excursion_restore, save_excursion_save ()); | |
1538 BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); | |
1539 readevalloop (buf, XBUFFER (buf)->filename, Feval, | |
1540 !NILP (printflag)); | |
1541 | |
771 | 1542 return unbind_to (speccount); |
428 | 1543 } |
1544 | |
1545 #if 0 | |
826 | 1546 DEFUN ("eval-current-buffer", Feval_current_buffer, 0, 1, "", /* |
428 | 1547 Execute the current buffer as Lisp code. |
1548 Programs can pass argument PRINTFLAG which controls printing of output: | |
1549 nil means discard it; anything else is stream for print. | |
1550 | |
1551 If there is no error, point does not move. If there is an error, | |
1552 point remains at the end of the last character read from the buffer. | |
1553 */ | |
1554 (printflag)) | |
1555 { | |
1556 code omitted; | |
1557 } | |
1558 #endif /* 0 */ | |
1559 | |
1560 DEFUN ("eval-region", Feval_region, 2, 3, "r", /* | |
1561 Execute the region as Lisp code. | |
444 | 1562 When called from programs, expects two arguments START and END |
428 | 1563 giving starting and ending indices in the current buffer |
1564 of the text to be executed. | |
444 | 1565 Programs can pass third optional argument STREAM which controls output: |
428 | 1566 nil means discard it; anything else is stream for printing it. |
1567 | |
1568 If there is no error, point does not move. If there is an error, | |
1569 point remains at the end of the last character read from the buffer. | |
1570 | |
1571 Note: Before evaling the region, this function narrows the buffer to it. | |
1572 If the code being eval'd should happen to trigger a redisplay you may | |
1573 see some text temporarily disappear because of this. | |
1574 */ | |
444 | 1575 (start, end, stream)) |
428 | 1576 { |
1577 /* This function can GC */ | |
1578 int speccount = specpdl_depth (); | |
1579 Lisp_Object tem; | |
1580 Lisp_Object cbuf = Fcurrent_buffer (); | |
1581 | |
444 | 1582 if (NILP (stream)) |
428 | 1583 tem = Qsymbolp; /* #### #@[]*&$#*[& SI:NULL-STREAM */ |
1584 else | |
444 | 1585 tem = stream; |
428 | 1586 specbind (Qstandard_output, tem); |
1587 | |
444 | 1588 if (NILP (stream)) |
428 | 1589 record_unwind_protect (save_excursion_restore, save_excursion_save ()); |
844 | 1590 record_unwind_protect (save_restriction_restore, |
1591 save_restriction_save (current_buffer)); | |
428 | 1592 |
444 | 1593 /* This both uses start and checks its type. */ |
1594 Fgoto_char (start, cbuf); | |
1595 Fnarrow_to_region (make_int (BUF_BEGV (current_buffer)), end, cbuf); | |
428 | 1596 readevalloop (cbuf, XBUFFER (cbuf)->filename, Feval, |
444 | 1597 !NILP (stream)); |
428 | 1598 |
771 | 1599 return unbind_to (speccount); |
428 | 1600 } |
1601 | |
1602 DEFUN ("read", Fread, 0, 1, 0, /* | |
1603 Read one Lisp expression as text from STREAM, return as Lisp object. | |
1604 If STREAM is nil, use the value of `standard-input' (which see). | |
1605 STREAM or the value of `standard-input' may be: | |
1606 a buffer (read from point and advance it) | |
1607 a marker (read from where it points and advance it) | |
1608 a function (call it with no arguments for each character, | |
1609 call it with a char as argument to push a char back) | |
1610 a string (takes text from string, starting at the beginning) | |
1611 t (read text line using minibuffer and use it). | |
1612 */ | |
1613 (stream)) | |
1614 { | |
1615 if (NILP (stream)) | |
1616 stream = Vstandard_input; | |
1617 if (EQ (stream, Qt)) | |
1618 stream = Qread_char; | |
1619 | |
1620 Vread_objects = Qnil; | |
1621 | |
1622 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
1623 Vcurrent_compiled_function_annotation = Qnil; | |
1624 #endif | |
1625 if (EQ (stream, Qread_char)) | |
1626 { | |
1627 Lisp_Object val = call1 (Qread_from_minibuffer, | |
771 | 1628 build_msg_string ("Lisp expression: ")); |
428 | 1629 return Fcar (Fread_from_string (val, Qnil, Qnil)); |
1630 } | |
1631 | |
1632 if (STRINGP (stream)) | |
1633 return Fcar (Fread_from_string (stream, Qnil, Qnil)); | |
1634 | |
1635 return read0 (stream); | |
1636 } | |
1637 | |
1638 DEFUN ("read-from-string", Fread_from_string, 1, 3, 0, /* | |
1639 Read one Lisp expression which is represented as text by STRING. | |
1640 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX). | |
1641 START and END optionally delimit a substring of STRING from which to read; | |
1642 they default to 0 and (length STRING) respectively. | |
1643 */ | |
1644 (string, start, end)) | |
1645 { | |
1646 Bytecount startval, endval; | |
1647 Lisp_Object tem; | |
1648 Lisp_Object lispstream = Qnil; | |
1649 struct gcpro gcpro1; | |
1650 | |
1651 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
1652 Vcurrent_compiled_function_annotation = Qnil; | |
1653 #endif | |
1654 GCPRO1 (lispstream); | |
1655 CHECK_STRING (string); | |
1656 get_string_range_byte (string, start, end, &startval, &endval, | |
1657 GB_HISTORICAL_STRING_BEHAVIOR); | |
1658 lispstream = make_lisp_string_input_stream (string, startval, | |
1659 endval - startval); | |
1660 | |
1661 Vread_objects = Qnil; | |
1662 | |
1663 tem = read0 (lispstream); | |
1664 /* Yeah, it's ugly. Gonna make something of it? | |
1665 At least our reader is reentrant ... */ | |
1666 tem = | |
1667 (Fcons (tem, make_int | |
793 | 1668 (string_index_byte_to_char |
771 | 1669 (string, |
428 | 1670 startval + Lstream_byte_count (XLSTREAM (lispstream)))))); |
1671 Lstream_delete (XLSTREAM (lispstream)); | |
1672 UNGCPRO; | |
1673 return tem; | |
1674 } | |
1675 | |
1676 | |
1677 | |
1678 /* Use this for recursive reads, in contexts where internal tokens | |
1679 are not allowed. See also read1(). */ | |
1680 static Lisp_Object | |
1681 read0 (Lisp_Object readcharfun) | |
1682 { | |
1683 Lisp_Object val = read1 (readcharfun); | |
1684 | |
1685 if (CONSP (val) && UNBOUNDP (XCAR (val))) | |
1686 { | |
867 | 1687 Ichar c = XCHAR (XCDR (val)); |
853 | 1688 free_cons (val); |
428 | 1689 return Fsignal (Qinvalid_read_syntax, |
1690 list1 (Fchar_to_string (make_char (c)))); | |
1691 } | |
1692 | |
1693 return val; | |
1694 } | |
3543 | 1695 |
1696 /* A Unicode escape, as in C# (though we only permit them in strings | |
1697 and characters, not arbitrarily in the source code.) */ | |
1698 static Ichar | |
1699 read_unicode_escape (Lisp_Object readcharfun, int unicode_hex_count) | |
1700 { | |
1701 REGISTER Ichar i = 0, c; | |
1702 REGISTER int count = 0; | |
1703 Lisp_Object lisp_char; | |
1704 while (++count <= unicode_hex_count) | |
1705 { | |
1706 c = readchar (readcharfun); | |
1707 /* Remember, can't use isdigit(), isalpha() etc. on Ichars */ | |
1708 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); | |
1709 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; | |
1710 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10; | |
1711 else | |
1712 { | |
1713 syntax_error ("Non-hex digit used for Unicode escape", | |
1714 make_char (c)); | |
1715 break; | |
1716 } | |
1717 } | |
1718 | |
4268 | 1719 if (i >= 0x110000 || i < 0) |
4096 | 1720 { |
1721 syntax_error ("Not a Unicode code point", make_int(i)); | |
1722 } | |
1723 | |
3543 | 1724 lisp_char = Funicode_to_char(make_int(i), Qnil); |
1725 | |
1726 if (EQ(Qnil, lisp_char)) | |
1727 { | |
4096 | 1728 /* Will happen on non-Mule. Silent corruption is what happens |
1729 elsewhere, and we used to do that to be consistent, but GNU error, | |
1730 so people writing portable code need to be able to handle that, and | |
1731 given a choice I prefer that behaviour. | |
1732 | |
1733 An undesirable aspect to this error is that the code point is shown | |
1734 as a decimal integer, which is mostly unreadable. */ | |
1735 syntax_error ("Unsupported Unicode code point", make_int(i)); | |
3543 | 1736 } |
4096 | 1737 |
1738 return XCHAR(lisp_char); | |
3543 | 1739 } |
1740 | |
428 | 1741 |
867 | 1742 static Ichar |
428 | 1743 read_escape (Lisp_Object readcharfun) |
1744 { | |
1745 /* This function can GC */ | |
867 | 1746 Ichar c = readchar (readcharfun); |
428 | 1747 |
1748 if (c < 0) | |
563 | 1749 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 1750 |
1751 switch (c) | |
1752 { | |
1753 case 'a': return '\007'; | |
1754 case 'b': return '\b'; | |
1755 case 'd': return 0177; | |
1756 case 'e': return 033; | |
1757 case 'f': return '\f'; | |
1758 case 'n': return '\n'; | |
1759 case 'r': return '\r'; | |
1760 case 't': return '\t'; | |
1761 case 'v': return '\v'; | |
1762 case '\n': return -1; | |
1763 | |
1764 case 'M': | |
1765 c = readchar (readcharfun); | |
1766 if (c < 0) | |
563 | 1767 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 1768 if (c != '-') |
563 | 1769 syntax_error ("Invalid escape character syntax", Qunbound); |
428 | 1770 c = readchar (readcharfun); |
1771 if (c < 0) | |
563 | 1772 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 1773 if (c == '\\') |
1774 c = read_escape (readcharfun); | |
1775 return c | 0200; | |
1776 | |
1777 /* Originally, FSF_KEYS provided a degree of FSF Emacs | |
1778 compatibility by defining character "modifiers" alt, super, | |
1779 hyper and shift to infest the characters (i.e. integers). | |
1780 | |
1781 However, this doesn't cut it for XEmacs 20, which | |
1782 distinguishes characters from integers. Without Mule, ?\H-a | |
1783 simply returns ?a because every character is clipped into | |
1784 0-255. Under Mule it is much worse -- ?\H-a with FSF_KEYS | |
1785 produces an illegal character, and moves us to crash-land. | |
1786 | |
1787 For these reasons, FSF_KEYS hack is useless and without hope | |
1788 of ever working under XEmacs 20. */ | |
1789 #ifdef FSF_KEYS | |
831 | 1790 /* Deleted */ |
1791 #endif | |
428 | 1792 |
1793 case 'C': | |
1794 c = readchar (readcharfun); | |
1795 if (c < 0) | |
563 | 1796 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 1797 if (c != '-') |
563 | 1798 syntax_error ("Invalid escape character syntax", Qunbound); |
428 | 1799 case '^': |
1800 c = readchar (readcharfun); | |
1801 if (c < 0) | |
563 | 1802 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 1803 if (c == '\\') |
1804 c = read_escape (readcharfun); | |
1805 /* FSFmacs junk for non-ASCII controls. | |
1806 Not used here. */ | |
1807 if (c == '?') | |
1808 return 0177; | |
1809 else | |
1810 return c & (0200 | 037); | |
1811 | |
1812 case '0': | |
1813 case '1': | |
1814 case '2': | |
1815 case '3': | |
1816 case '4': | |
1817 case '5': | |
1818 case '6': | |
1819 case '7': | |
1820 /* An octal escape, as in ANSI C. */ | |
1821 { | |
867 | 1822 REGISTER Ichar i = c - '0'; |
428 | 1823 REGISTER int count = 0; |
1824 while (++count < 3) | |
1825 { | |
1826 if ((c = readchar (readcharfun)) >= '0' && c <= '7') | |
1827 i = (i << 3) + (c - '0'); | |
1828 else | |
1829 { | |
1830 unreadchar (readcharfun, c); | |
1831 break; | |
1832 } | |
1833 } | |
831 | 1834 if (i >= 0400) |
3367 | 1835 syntax_error ("Non-ISO-8859-1 character specified with octal escape", |
831 | 1836 make_int (i)); |
428 | 1837 return i; |
1838 } | |
1839 | |
1840 case 'x': | |
1841 /* A hex escape, as in ANSI C, except that we only allow latin-1 | |
1842 characters to be read this way. What is "\x4e03" supposed to | |
1843 mean, anyways, if the internal representation is hidden? | |
1844 This is also consistent with the treatment of octal escapes. */ | |
1845 { | |
867 | 1846 REGISTER Ichar i = 0; |
428 | 1847 REGISTER int count = 0; |
1848 while (++count <= 2) | |
1849 { | |
1850 c = readchar (readcharfun); | |
867 | 1851 /* Remember, can't use isdigit(), isalpha() etc. on Ichars */ |
428 | 1852 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); |
1853 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; | |
1854 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10; | |
1855 else | |
1856 { | |
1857 unreadchar (readcharfun, c); | |
1858 break; | |
1859 } | |
1860 } | |
4483
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1861 |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1862 if (count == 3) |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1863 { |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1864 c = readchar (readcharfun); |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1865 if ((c >= '0' && c <= '9') || |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1866 (c >= 'a' && c <= 'f') || |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1867 (c >= 'A' && c <= 'F')) |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1868 { |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1869 Lisp_Object args[2]; |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1870 |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1871 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0'); |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1872 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10; |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1873 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10; |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1874 |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1875 args[0] = build_string ("?\\x%x"); |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1876 args[1] = make_int (i); |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1877 syntax_error ("Overlong hex character escape", |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1878 Fformat (2, args)); |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1879 } |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1880 unreadchar (readcharfun, c); |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1881 } |
7869173584fc
Error on over-long hex character escapes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4450
diff
changeset
|
1882 |
428 | 1883 return i; |
1884 } | |
3367 | 1885 case 'U': |
1886 /* Post-Unicode-2.0: Up to eight hex chars */ | |
3543 | 1887 return read_unicode_escape(readcharfun, 8); |
3367 | 1888 case 'u': |
3543 | 1889 /* Unicode-2.0 and before; four hex chars. */ |
1890 return read_unicode_escape(readcharfun, 4); | |
428 | 1891 |
1892 default: | |
1893 return c; | |
1894 } | |
1895 } | |
1896 | |
1897 | |
1898 | |
1899 /* read symbol-constituent stuff into `Vread_buffer_stream'. */ | |
1900 static Bytecount | |
867 | 1901 read_atom_0 (Lisp_Object readcharfun, Ichar firstchar, int *saw_a_backslash) |
428 | 1902 { |
1903 /* This function can GC */ | |
867 | 1904 Ichar c = ((firstchar) >= 0 ? firstchar : readchar (readcharfun)); |
428 | 1905 Lstream_rewind (XLSTREAM (Vread_buffer_stream)); |
1906 | |
1907 *saw_a_backslash = 0; | |
1908 | |
1909 while (c > 040 /* #### - comma should be here as should backquote */ | |
1910 && !(c == '\"' || c == '\'' || c == ';' | |
1911 || c == '(' || c == ')' | |
1912 || c == '[' || c == ']' || c == '#' | |
1913 )) | |
1914 { | |
1915 if (c == '\\') | |
1916 { | |
1917 c = readchar (readcharfun); | |
1918 if (c < 0) | |
563 | 1919 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 1920 *saw_a_backslash = 1; |
1921 } | |
867 | 1922 Lstream_put_ichar (XLSTREAM (Vread_buffer_stream), c); |
428 | 1923 QUIT; |
1924 c = readchar (readcharfun); | |
1925 } | |
1926 | |
1927 if (c >= 0) | |
1928 unreadchar (readcharfun, c); | |
1929 /* blasted terminating 0 */ | |
867 | 1930 Lstream_put_ichar (XLSTREAM (Vread_buffer_stream), 0); |
428 | 1931 Lstream_flush (XLSTREAM (Vread_buffer_stream)); |
1932 | |
1933 return Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) - 1; | |
1934 } | |
1935 | |
867 | 1936 static Lisp_Object parse_integer (const Ibyte *buf, Bytecount len, int base); |
428 | 1937 |
1938 static Lisp_Object | |
1939 read_atom (Lisp_Object readcharfun, | |
867 | 1940 Ichar firstchar, |
428 | 1941 int uninterned_symbol) |
1942 { | |
1943 /* This function can GC */ | |
1944 int saw_a_backslash; | |
1945 Bytecount len = read_atom_0 (readcharfun, firstchar, &saw_a_backslash); | |
1946 char *read_ptr = (char *) | |
1947 resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)); | |
1948 | |
1949 /* Is it an integer? */ | |
1950 if (! (saw_a_backslash || uninterned_symbol)) | |
1951 { | |
1952 /* If a token had any backslashes in it, it is disqualified from | |
1953 being an integer or a float. This means that 123\456 is a | |
1954 symbol, as is \123 (which is the way (intern "123") prints). | |
1955 Also, if token was preceded by #:, it's always a symbol. | |
1956 */ | |
1957 char *p = read_ptr + len; | |
1958 char *p1 = read_ptr; | |
1959 | |
1960 if (*p1 == '+' || *p1 == '-') p1++; | |
1961 if (p1 != p) | |
1962 { | |
1963 int c; | |
1964 | |
1965 while (p1 != p && (c = *p1) >= '0' && c <= '9') | |
1966 p1++; | |
1967 /* Integers can have trailing decimal points. */ | |
1968 if (p1 > read_ptr && p1 < p && *p1 == '.') | |
1969 p1++; | |
1970 if (p1 == p) | |
1971 { | |
1972 /* It is an integer. */ | |
1973 if (p1[-1] == '.') | |
1974 p1[-1] = '\0'; | |
1975 #if 0 | |
1976 { | |
1977 int number = 0; | |
1978 if (sizeof (int) == sizeof (EMACS_INT)) | |
1979 number = atoi (read_buffer); | |
1980 else if (sizeof (long) == sizeof (EMACS_INT)) | |
1981 number = atol (read_buffer); | |
1982 else | |
2500 | 1983 ABORT (); |
428 | 1984 return make_int (number); |
1985 } | |
1986 #else | |
867 | 1987 return parse_integer ((Ibyte *) read_ptr, len, 10); |
428 | 1988 #endif |
1989 } | |
1990 } | |
1983 | 1991 #ifdef HAVE_RATIO |
1992 if (isratio_string (read_ptr)) | |
1993 { | |
2013 | 1994 /* GMP ratio_set_string has no effect with initial + sign */ |
2010 | 1995 if (*read_ptr == '+') |
1996 read_ptr++; | |
1983 | 1997 ratio_set_string (scratch_ratio, read_ptr, 0); |
1998 ratio_canonicalize (scratch_ratio); | |
1999 return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); | |
2000 } | |
2001 #endif | |
428 | 2002 if (isfloat_string (read_ptr)) |
2003 return make_float (atof (read_ptr)); | |
2004 } | |
2005 | |
2006 { | |
2007 Lisp_Object sym; | |
2008 if (uninterned_symbol) | |
867 | 2009 sym = Fmake_symbol ( make_string ((Ibyte *) read_ptr, len)); |
428 | 2010 else |
2011 { | |
867 | 2012 Lisp_Object name = make_string ((Ibyte *) read_ptr, len); |
428 | 2013 sym = Fintern (name, Qnil); |
2014 } | |
2015 return sym; | |
2016 } | |
2017 } | |
2018 | |
2019 | |
2020 static Lisp_Object | |
867 | 2021 parse_integer (const Ibyte *buf, Bytecount len, int base) |
428 | 2022 { |
867 | 2023 const Ibyte *lim = buf + len; |
2024 const Ibyte *p = buf; | |
428 | 2025 EMACS_UINT num = 0; |
2026 int negativland = 0; | |
2027 | |
2028 if (*p == '-') | |
2029 { | |
2030 negativland = 1; | |
2031 p++; | |
2032 } | |
2033 else if (*p == '+') | |
2034 { | |
2035 p++; | |
2036 } | |
2037 | |
2038 if (p == lim) | |
2039 goto loser; | |
2040 | |
2041 for (; (p < lim) && (*p != '\0'); p++) | |
2042 { | |
2043 int c = *p; | |
2044 EMACS_UINT onum; | |
2045 | |
2046 if (isdigit (c)) | |
2047 c = c - '0'; | |
2048 else if (isupper (c)) | |
2049 c = c - 'A' + 10; | |
2050 else if (islower (c)) | |
2051 c = c - 'a' + 10; | |
2052 else | |
2053 goto loser; | |
2054 | |
2055 if (c < 0 || c >= base) | |
2056 goto loser; | |
2057 | |
2058 onum = num; | |
2059 num = num * base + c; | |
2060 if (num < onum) | |
2061 goto overflow; | |
2062 } | |
2063 | |
2064 { | |
2065 EMACS_INT int_result = negativland ? - (EMACS_INT) num : (EMACS_INT) num; | |
2066 Lisp_Object result = make_int (int_result); | |
2067 if (num && ((XINT (result) < 0) != negativland)) | |
2068 goto overflow; | |
2069 if (XINT (result) != int_result) | |
2070 goto overflow; | |
2071 return result; | |
2072 } | |
2073 overflow: | |
1983 | 2074 #ifdef HAVE_BIGNUM |
2075 { | |
4329
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4268
diff
changeset
|
2076 bignum_set_string (scratch_bignum, (const char *) buf, base); |
1983 | 2077 return make_bignum_bg (scratch_bignum); |
2078 } | |
2079 #else | |
428 | 2080 return Fsignal (Qinvalid_read_syntax, |
771 | 2081 list3 (build_msg_string |
428 | 2082 ("Integer constant overflow in reader"), |
2083 make_string (buf, len), | |
2084 make_int (base))); | |
1983 | 2085 #endif /* HAVE_BIGNUM */ |
428 | 2086 loser: |
2087 return Fsignal (Qinvalid_read_syntax, | |
771 | 2088 list3 (build_msg_string |
428 | 2089 ("Invalid integer constant in reader"), |
2090 make_string (buf, len), | |
2091 make_int (base))); | |
2092 } | |
2093 | |
2094 | |
2095 static Lisp_Object | |
2096 read_integer (Lisp_Object readcharfun, int base) | |
2097 { | |
2098 /* This function can GC */ | |
2099 int saw_a_backslash; | |
2100 Bytecount len = read_atom_0 (readcharfun, -1, &saw_a_backslash); | |
2101 return (parse_integer | |
2102 (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)), | |
2103 ((saw_a_backslash) | |
2104 ? 0 /* make parse_integer signal error */ | |
2105 : len), | |
2106 base)); | |
2107 } | |
2108 | |
2109 static Lisp_Object | |
2110 read_bit_vector (Lisp_Object readcharfun) | |
2111 { | |
2112 unsigned_char_dynarr *dyn = Dynarr_new (unsigned_char); | |
440 | 2113 Lisp_Object val; |
428 | 2114 |
2115 while (1) | |
2116 { | |
444 | 2117 unsigned char bit; |
867 | 2118 Ichar c = readchar (readcharfun); |
444 | 2119 if (c == '0') |
2120 bit = 0; | |
2121 else if (c == '1') | |
2122 bit = 1; | |
2123 else | |
2124 { | |
2125 if (c >= 0) | |
2126 unreadchar (readcharfun, c); | |
2127 break; | |
2128 } | |
2129 Dynarr_add (dyn, bit); | |
428 | 2130 } |
2131 | |
440 | 2132 val = make_bit_vector_from_byte_vector (Dynarr_atp (dyn, 0), |
2133 Dynarr_length (dyn)); | |
2134 Dynarr_free (dyn); | |
2135 | |
2136 return val; | |
428 | 2137 } |
2138 | |
2139 | |
2140 | |
2141 /* structures */ | |
2142 | |
2143 struct structure_type * | |
2144 define_structure_type (Lisp_Object type, | |
2145 int (*validate) (Lisp_Object data, | |
578 | 2146 Error_Behavior errb), |
428 | 2147 Lisp_Object (*instantiate) (Lisp_Object data)) |
2148 { | |
2149 struct structure_type st; | |
2150 | |
2151 st.type = type; | |
2152 st.keywords = Dynarr_new (structure_keyword_entry); | |
2153 st.validate = validate; | |
2154 st.instantiate = instantiate; | |
2155 Dynarr_add (the_structure_type_dynarr, st); | |
2156 | |
4844
91b3d00e717f
Various cleanups for Dynarr code, from Unicode-internal ws
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
2157 return Dynarr_lastp (the_structure_type_dynarr); |
428 | 2158 } |
2159 | |
2160 void | |
2161 define_structure_type_keyword (struct structure_type *st, Lisp_Object keyword, | |
2162 int (*validate) (Lisp_Object keyword, | |
2163 Lisp_Object value, | |
578 | 2164 Error_Behavior errb)) |
428 | 2165 { |
2166 struct structure_keyword_entry en; | |
2167 | |
2168 en.keyword = keyword; | |
2169 en.validate = validate; | |
2170 Dynarr_add (st->keywords, en); | |
2171 } | |
2172 | |
2173 static struct structure_type * | |
2174 recognized_structure_type (Lisp_Object type) | |
2175 { | |
2176 int i; | |
2177 | |
2178 for (i = 0; i < Dynarr_length (the_structure_type_dynarr); i++) | |
2179 { | |
2180 struct structure_type *st = Dynarr_atp (the_structure_type_dynarr, i); | |
2181 if (EQ (st->type, type)) | |
2182 return st; | |
2183 } | |
2184 | |
2185 return 0; | |
2186 } | |
2187 | |
2188 static Lisp_Object | |
2189 read_structure (Lisp_Object readcharfun) | |
2190 { | |
867 | 2191 Ichar c = readchar (readcharfun); |
428 | 2192 Lisp_Object list = Qnil; |
2193 Lisp_Object orig_list = Qnil; | |
2194 Lisp_Object already_seen = Qnil; | |
2195 int keyword_count; | |
2196 struct structure_type *st; | |
2197 struct gcpro gcpro1, gcpro2; | |
2198 | |
2199 GCPRO2 (orig_list, already_seen); | |
2200 if (c != '(') | |
442 | 2201 RETURN_UNGCPRO (continuable_read_syntax_error ("#s not followed by paren")); |
428 | 2202 list = read_list (readcharfun, ')', 0, 0); |
2203 orig_list = list; | |
2204 { | |
2205 int len = XINT (Flength (list)); | |
2206 if (len == 0) | |
442 | 2207 RETURN_UNGCPRO (continuable_read_syntax_error |
428 | 2208 ("structure type not specified")); |
2209 if (!(len & 1)) | |
2210 RETURN_UNGCPRO | |
442 | 2211 (continuable_read_syntax_error |
428 | 2212 ("structures must have alternating keyword/value pairs")); |
2213 } | |
2214 | |
2215 st = recognized_structure_type (XCAR (list)); | |
2216 if (!st) | |
2217 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
771 | 2218 list2 (build_msg_string |
428 | 2219 ("unrecognized structure type"), |
2220 XCAR (list)))); | |
2221 | |
2222 list = Fcdr (list); | |
2223 keyword_count = Dynarr_length (st->keywords); | |
2224 while (!NILP (list)) | |
2225 { | |
2226 Lisp_Object keyword, value; | |
2227 int i; | |
2228 struct structure_keyword_entry *en = NULL; | |
2229 | |
2230 keyword = Fcar (list); | |
2231 list = Fcdr (list); | |
2232 value = Fcar (list); | |
2233 list = Fcdr (list); | |
2234 | |
2235 if (!NILP (memq_no_quit (keyword, already_seen))) | |
2236 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
771 | 2237 list2 (build_msg_string |
428 | 2238 ("structure keyword already seen"), |
2239 keyword))); | |
2240 | |
2241 for (i = 0; i < keyword_count; i++) | |
2242 { | |
2243 en = Dynarr_atp (st->keywords, i); | |
2244 if (EQ (keyword, en->keyword)) | |
2245 break; | |
2246 } | |
2247 | |
2248 if (i == keyword_count) | |
2249 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
771 | 2250 list2 (build_msg_string |
428 | 2251 ("unrecognized structure keyword"), |
2252 keyword))); | |
2253 | |
2254 if (en->validate && ! (en->validate) (keyword, value, ERROR_ME)) | |
2255 RETURN_UNGCPRO | |
2256 (Fsignal (Qinvalid_read_syntax, | |
771 | 2257 list3 (build_msg_string |
428 | 2258 ("invalid value for structure keyword"), |
2259 keyword, value))); | |
2260 | |
2261 already_seen = Fcons (keyword, already_seen); | |
2262 } | |
2263 | |
2264 if (st->validate && ! (st->validate) (orig_list, ERROR_ME)) | |
2265 RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax, | |
771 | 2266 list2 (build_msg_string |
428 | 2267 ("invalid structure initializer"), |
2268 orig_list))); | |
2269 | |
2270 RETURN_UNGCPRO ((st->instantiate) (XCDR (orig_list))); | |
2271 } | |
2272 | |
2273 | |
2274 static Lisp_Object read_compiled_function (Lisp_Object readcharfun, | |
2275 int terminator); | |
2276 static Lisp_Object read_vector (Lisp_Object readcharfun, int terminator); | |
2277 | |
2278 /* Get the next character; filter out whitespace and comments */ | |
2279 | |
867 | 2280 static Ichar |
428 | 2281 reader_nextchar (Lisp_Object readcharfun) |
2282 { | |
2283 /* This function can GC */ | |
867 | 2284 Ichar c; |
428 | 2285 |
2286 retry: | |
2287 QUIT; | |
2288 c = readchar (readcharfun); | |
2289 if (c < 0) | |
563 | 2290 signal_error (Qend_of_file, 0, READCHARFUN_MAYBE (readcharfun)); |
428 | 2291 |
2292 switch (c) | |
2293 { | |
2294 default: | |
2295 { | |
2296 /* Ignore whitespace and control characters */ | |
2297 if (c <= 040) | |
2298 goto retry; | |
2299 return c; | |
2300 } | |
2301 | |
2302 case ';': | |
2303 { | |
2304 /* Comment */ | |
2305 while ((c = readchar (readcharfun)) >= 0 && c != '\n') | |
2306 QUIT; | |
2307 goto retry; | |
2308 } | |
2309 } | |
2310 } | |
2311 | |
2312 #if 0 | |
2313 static Lisp_Object | |
2314 list2_pure (int pure, Lisp_Object a, Lisp_Object b) | |
2315 { | |
2316 return pure ? pure_cons (a, pure_cons (b, Qnil)) : list2 (a, b); | |
2317 } | |
2318 #endif | |
2319 | |
3543 | 2320 static Lisp_Object |
2321 read_string (Lisp_Object readcharfun, Ichar delim, int raw, | |
2322 int honor_unicode) | |
2323 { | |
2324 #ifdef I18N3 | |
2325 /* #### If the input stream is translating, then the string | |
2326 should be marked as translatable by setting its | |
2327 `string-translatable' property to t. .el and .elc files | |
2328 normally are translating input streams. See Fgettext() | |
2329 and print_internal(). */ | |
2330 #endif | |
2331 Ichar c; | |
2332 int cancel = 0; | |
2333 | |
2334 Lstream_rewind(XLSTREAM(Vread_buffer_stream)); | |
2335 while ((c = readchar(readcharfun)) >= 0 && c != delim) | |
2336 { | |
2337 if (c == '\\') | |
2338 { | |
2339 if (raw) | |
2340 { | |
2341 c = readchar(readcharfun); | |
2342 if (honor_unicode && ('u' == c || 'U' == c)) | |
2343 { | |
2344 c = read_unicode_escape(readcharfun, | |
2345 'U' == c ? 8 : 4); | |
2346 } | |
2347 else | |
2348 { | |
2349 /* For raw strings, insert the | |
2350 backslash and the next char, */ | |
2351 Lstream_put_ichar(XLSTREAM | |
2352 (Vread_buffer_stream), | |
2353 '\\'); | |
2354 } | |
2355 } | |
2356 else | |
2357 /* otherwise, backslash escapes the next char. */ | |
2358 c = read_escape(readcharfun); | |
2359 } | |
2360 /* c is -1 if \ newline has just been seen */ | |
2361 if (c == -1) | |
2362 { | |
2363 if (Lstream_byte_count | |
2364 (XLSTREAM(Vread_buffer_stream)) == | |
2365 0) | |
2366 cancel = 1; | |
2367 } | |
2368 else | |
2369 Lstream_put_ichar(XLSTREAM | |
2370 (Vread_buffer_stream), | |
2371 c); | |
2372 QUIT; | |
2373 } | |
2374 if (c < 0) | |
2375 return Fsignal(Qend_of_file, | |
2376 list1(READCHARFUN_MAYBE(readcharfun))); | |
2377 | |
2378 /* If purifying, and string starts with \ newline, | |
2379 return zero instead. This is for doc strings | |
2380 that we are really going to find in lib-src/DOC.nn.nn */ | |
2381 if (purify_flag && NILP(Vinternal_doc_file_name) | |
2382 && cancel) | |
2383 return Qzero; | |
2384 | |
2385 Lstream_flush(XLSTREAM(Vread_buffer_stream)); | |
2386 return make_string(resizing_buffer_stream_ptr | |
2387 (XLSTREAM(Vread_buffer_stream)), | |
2388 Lstream_byte_count(XLSTREAM(Vread_buffer_stream))); | |
2389 } | |
2390 | |
2391 static Lisp_Object | |
2392 read_raw_string (Lisp_Object readcharfun) | |
2393 { | |
2394 Ichar c; | |
2395 Ichar permit_unicode = 0; | |
2396 | |
2397 do { | |
2398 c = reader_nextchar(readcharfun); | |
2399 switch (c) { | |
2400 /* #r:engine"my sexy raw string" -- raw string w/ flags*/ | |
2401 /* case ':': */ | |
2402 /* #ru"Hi there\u20AC \U000020AC" -- raw string, honouring Unicode. */ | |
2403 case 'u': | |
2404 case 'U': | |
2405 permit_unicode = c; | |
2406 continue; | |
2407 | |
2408 /* #r"my raw string" -- raw string */ | |
2409 case '\"': | |
2410 return read_string(readcharfun, '\"', 1, permit_unicode); | |
2411 /* invalid syntax */ | |
2412 default: | |
2413 { | |
2414 if (permit_unicode) | |
2415 { | |
2416 unreadchar(readcharfun, permit_unicode); | |
2417 } | |
2418 unreadchar(readcharfun, c); | |
2419 return Fsignal(Qinvalid_read_syntax, | |
2420 list1(build_string | |
2421 ("unrecognized raw string syntax"))); | |
2422 } | |
2423 } | |
2424 } while (1); | |
2425 } | |
2426 | |
428 | 2427 /* Read the next Lisp object from the stream READCHARFUN and return it. |
2428 If the return value is a cons whose car is Qunbound, then read1() | |
2429 encountered a misplaced token (e.g. a right bracket, right paren, | |
2430 or dot followed by a non-number). To filter this stuff out, | |
2431 use read0(). */ | |
2432 | |
2433 static Lisp_Object | |
2434 read1 (Lisp_Object readcharfun) | |
2435 { | |
867 | 2436 Ichar c; |
428 | 2437 |
2438 retry: | |
2439 c = reader_nextchar (readcharfun); | |
2440 | |
2441 switch (c) | |
2442 { | |
2443 case '(': | |
2444 { | |
2445 #ifdef LISP_BACKQUOTES /* old backquote compatibility in lisp reader */ | |
2446 /* if this is disabled, then other code in eval.c must be enabled */ | |
867 | 2447 Ichar ch = reader_nextchar (readcharfun); |
428 | 2448 switch (ch) |
2449 { | |
2450 case '`': | |
2451 { | |
2452 Lisp_Object tem; | |
853 | 2453 int speccount = internal_bind_int (&old_backquote_flag, |
2454 1 + old_backquote_flag); | |
428 | 2455 tem = read0 (readcharfun); |
771 | 2456 unbind_to (speccount); |
428 | 2457 ch = reader_nextchar (readcharfun); |
2458 if (ch != ')') | |
2459 { | |
2460 unreadchar (readcharfun, ch); | |
2461 return Fsignal (Qinvalid_read_syntax, | |
771 | 2462 list1 (build_msg_string |
428 | 2463 ("Weird old-backquote syntax"))); |
2464 } | |
2465 return list2 (Qbacktick, tem); | |
2466 } | |
2467 case ',': | |
2468 { | |
2469 if (old_backquote_flag) | |
2470 { | |
2471 Lisp_Object tem, comma_type; | |
2472 ch = readchar (readcharfun); | |
2473 if (ch == '@') | |
2474 comma_type = Qcomma_at; | |
2475 else | |
2476 { | |
2477 if (ch >= 0) | |
2478 unreadchar (readcharfun, ch); | |
2479 comma_type = Qcomma; | |
2480 } | |
2481 tem = read0 (readcharfun); | |
2482 ch = reader_nextchar (readcharfun); | |
2483 if (ch != ')') | |
2484 { | |
2485 unreadchar (readcharfun, ch); | |
2486 return Fsignal (Qinvalid_read_syntax, | |
771 | 2487 list1 (build_msg_string |
428 | 2488 ("Weird old-backquote syntax"))); |
2489 } | |
2490 return list2 (comma_type, tem); | |
2491 } | |
2492 else | |
2493 { | |
2494 unreadchar (readcharfun, ch); | |
2495 #if 0 | |
2496 return Fsignal (Qinvalid_read_syntax, | |
771 | 2497 list1 (build_msg_string ("Comma outside of backquote"))); |
428 | 2498 #else |
2499 /* #### - yuck....but this is reverse compatible. */ | |
2500 /* mostly this is required by edebug, which does its own | |
2501 annotated reading. We need to have an annotated_read | |
2502 function that records (with markers) the buffer | |
2503 positions of the elements that make up lists, then that | |
2504 can be used in edebug and bytecomp and the check above | |
2505 can go back in. --Stig */ | |
2506 break; | |
2507 #endif | |
2508 } | |
2509 } | |
2510 default: | |
2511 unreadchar (readcharfun, ch); | |
2512 } /* switch(ch) */ | |
2513 #endif /* old backquote crap... */ | |
2514 return read_list (readcharfun, ')', 1, 1); | |
2515 } | |
2516 case '[': | |
2517 return read_vector (readcharfun, ']'); | |
2518 | |
2519 case ')': | |
2520 case ']': | |
2521 /* #### - huh? these don't do what they seem... */ | |
2522 return noseeum_cons (Qunbound, make_char (c)); | |
2523 case '.': | |
2524 { | |
2525 /* If a period is followed by a number, then we should read it | |
2526 as a floating point number. Otherwise, it denotes a dotted | |
2527 pair. | |
2528 */ | |
2529 c = readchar (readcharfun); | |
2530 unreadchar (readcharfun, c); | |
2531 | |
867 | 2532 /* Can't use isdigit on Ichars */ |
428 | 2533 if (c < '0' || c > '9') |
2534 return noseeum_cons (Qunbound, make_char ('.')); | |
2535 | |
2536 /* Note that read_atom will loop | |
2537 at least once, assuring that we will not try to UNREAD | |
2538 two characters in a row. | |
2539 (I think this doesn't matter anymore because there should | |
2540 be no more danger in unreading multiple characters) */ | |
2541 return read_atom (readcharfun, '.', 0); | |
2542 } | |
2543 | |
2544 case '#': | |
2545 { | |
2546 c = readchar (readcharfun); | |
2547 switch (c) | |
2548 { | |
2549 #if 0 /* FSFmacs silly char-table syntax */ | |
2550 case '^': | |
2551 #endif | |
2552 #if 0 /* FSFmacs silly bool-vector syntax */ | |
2553 case '&': | |
2554 #endif | |
2555 /* "#["-- byte-code constant syntax */ | |
2556 /* purecons #[...] syntax */ | |
2557 case '[': return read_compiled_function (readcharfun, ']' | |
2558 /*, purify_flag */ ); | |
2559 /* "#:"-- gensym syntax */ | |
2560 case ':': return read_atom (readcharfun, -1, 1); | |
2561 /* #'x => (function x) */ | |
2562 case '\'': return list2 (Qfunction, read0 (readcharfun)); | |
2563 #if 0 | |
2564 /* RMS uses this syntax for fat-strings. | |
2565 If we use it for vectors, then obscure bugs happen. | |
2566 */ | |
2567 /* "#(" -- Scheme/CL vector syntax */ | |
2568 case '(': return read_vector (readcharfun, ')'); | |
2569 #endif | |
2570 #if 0 /* FSFmacs */ | |
2571 case '(': | |
2572 { | |
2573 Lisp_Object tmp; | |
2574 struct gcpro gcpro1; | |
2575 | |
2576 /* Read the string itself. */ | |
2577 tmp = read1 (readcharfun); | |
2578 if (!STRINGP (tmp)) | |
2579 { | |
2580 if (CONSP (tmp) && UNBOUNDP (XCAR (tmp))) | |
853 | 2581 free_cons (tmp); |
428 | 2582 return Fsignal (Qinvalid_read_syntax, |
2583 list1 (build_string ("#"))); | |
2584 } | |
2585 GCPRO1 (tmp); | |
2586 /* Read the intervals and their properties. */ | |
2587 while (1) | |
2588 { | |
2589 Lisp_Object beg, end, plist; | |
867 | 2590 Ichar ch; |
428 | 2591 int invalid = 0; |
2592 | |
2593 beg = read1 (readcharfun); | |
2594 if (CONSP (beg) && UNBOUNDP (XCAR (beg))) | |
2595 { | |
2596 ch = XCHAR (XCDR (beg)); | |
853 | 2597 free_cons (beg); |
428 | 2598 if (ch == ')') |
2599 break; | |
2600 else | |
2601 invalid = 1; | |
2602 } | |
2603 if (!invalid) | |
2604 { | |
2605 end = read1 (readcharfun); | |
2606 if (CONSP (end) && UNBOUNDP (XCAR (end))) | |
2607 { | |
853 | 2608 free_cons (end); |
428 | 2609 invalid = 1; |
2610 } | |
2611 } | |
2612 if (!invalid) | |
2613 { | |
2614 plist = read1 (readcharfun); | |
2615 if (CONSP (plist) && UNBOUNDP (XCAR (plist))) | |
2616 { | |
853 | 2617 free_cons (plist); |
428 | 2618 invalid = 1; |
2619 } | |
2620 } | |
2621 if (invalid) | |
2622 RETURN_UNGCPRO | |
2623 (Fsignal (Qinvalid_read_syntax, | |
2624 list2 | |
771 | 2625 (build_msg_string ("invalid string property list"), |
428 | 2626 XCDR (plist)))); |
2627 Fset_text_properties (beg, end, plist, tmp); | |
2628 } | |
2629 UNGCPRO; | |
2630 return tmp; | |
2631 } | |
2632 #endif /* 0 */ | |
2633 case '@': | |
2634 { | |
2635 /* #@NUMBER is used to skip NUMBER following characters. | |
2636 That's used in .elc files to skip over doc strings | |
2637 and function definitions. */ | |
2638 int i, nskip = 0; | |
2639 | |
2640 /* Read a decimal integer. */ | |
2641 while ((c = readchar (readcharfun)) >= 0 | |
2642 && c >= '0' && c <= '9') | |
2643 nskip = (10 * nskip) + (c - '0'); | |
2644 if (c >= 0) | |
2645 unreadchar (readcharfun, c); | |
2646 | |
2647 /* FSF has code here that maybe caches the skipped | |
2648 string. See above for why this is totally | |
2649 losing. We handle this differently. */ | |
2650 | |
2651 /* Skip that many characters. */ | |
2652 for (i = 0; i < nskip && c >= 0; i++) | |
2653 c = readchar (readcharfun); | |
2654 | |
2655 goto retry; | |
2656 } | |
2657 case '$': return Vload_file_name_internal; | |
2658 /* bit vectors */ | |
2659 case '*': return read_bit_vector (readcharfun); | |
2660 /* #o10 => 8 -- octal constant syntax */ | |
2661 case 'o': return read_integer (readcharfun, 8); | |
2662 /* #xdead => 57005 -- hex constant syntax */ | |
2663 case 'x': return read_integer (readcharfun, 16); | |
2664 /* #b010 => 2 -- binary constant syntax */ | |
2665 case 'b': return read_integer (readcharfun, 2); | |
3543 | 2666 /* #r"raw\stringt" -- raw string syntax */ |
2667 case 'r': return read_raw_string(readcharfun); | |
428 | 2668 /* #s(foobar key1 val1 key2 val2) -- structure syntax */ |
2669 case 's': return read_structure (readcharfun); | |
2670 case '<': | |
2671 { | |
2672 unreadchar (readcharfun, c); | |
2673 return Fsignal (Qinvalid_read_syntax, | |
771 | 2674 list1 (build_msg_string ("Cannot read unreadable object"))); |
428 | 2675 } |
2676 #ifdef FEATUREP_SYNTAX | |
2677 case '+': | |
2678 case '-': | |
2679 { | |
456 | 2680 Lisp_Object feature_exp, obj, tem; |
428 | 2681 struct gcpro gcpro1, gcpro2; |
2682 | |
456 | 2683 feature_exp = read0(readcharfun); |
428 | 2684 obj = read0(readcharfun); |
2685 | |
2686 /* the call to `featurep' may GC. */ | |
456 | 2687 GCPRO2 (feature_exp, obj); |
2688 tem = call1 (Qfeaturep, feature_exp); | |
428 | 2689 UNGCPRO; |
2690 | |
2691 if (c == '+' && NILP(tem)) goto retry; | |
2692 if (c == '-' && !NILP(tem)) goto retry; | |
2693 return obj; | |
2694 } | |
2695 #endif | |
2696 case '0': case '1': case '2': case '3': case '4': | |
2697 case '5': case '6': case '7': case '8': case '9': | |
2698 /* Reader forms that can reuse previously read objects. */ | |
2699 { | |
2700 int n = 0; | |
2701 Lisp_Object found; | |
2702 | |
2703 /* Using read_integer() here is impossible, because it | |
2704 chokes on `='. Using parse_integer() is too hard. | |
2705 So we simply read it in, and ignore overflows, which | |
2706 is safe. */ | |
2707 while (c >= '0' && c <= '9') | |
2708 { | |
2709 n *= 10; | |
2710 n += c - '0'; | |
2711 c = readchar (readcharfun); | |
2712 } | |
2713 found = assq_no_quit (make_int (n), Vread_objects); | |
2714 if (c == '=') | |
2715 { | |
2716 /* #n=object returns object, but associates it with | |
2717 n for #n#. */ | |
2718 Lisp_Object obj; | |
2719 if (CONSP (found)) | |
2720 return Fsignal (Qinvalid_read_syntax, | |
771 | 2721 list2 (build_msg_string |
428 | 2722 ("Multiply defined symbol label"), |
2723 make_int (n))); | |
2724 obj = read0 (readcharfun); | |
2725 Vread_objects = Fcons (Fcons (make_int (n), obj), | |
2726 Vread_objects); | |
2727 return obj; | |
2728 } | |
2729 else if (c == '#') | |
2730 { | |
2731 /* #n# returns a previously read object. */ | |
2732 if (CONSP (found)) | |
2733 return XCDR (found); | |
2734 else | |
2735 return Fsignal (Qinvalid_read_syntax, | |
771 | 2736 list2 (build_msg_string |
428 | 2737 ("Undefined symbol label"), |
2738 make_int (n))); | |
2739 } | |
2740 return Fsignal (Qinvalid_read_syntax, | |
2741 list1 (build_string ("#"))); | |
2742 } | |
2743 default: | |
2744 { | |
2745 unreadchar (readcharfun, c); | |
2746 return Fsignal (Qinvalid_read_syntax, | |
2747 list1 (build_string ("#"))); | |
2748 } | |
2749 } | |
2750 } | |
2751 | |
2752 /* Quote */ | |
2753 case '\'': return list2 (Qquote, read0 (readcharfun)); | |
2754 | |
2755 #ifdef LISP_BACKQUOTES | |
2756 case '`': | |
2757 { | |
2758 Lisp_Object tem; | |
853 | 2759 int speccount = internal_bind_int (&new_backquote_flag, |
2760 1 + new_backquote_flag); | |
428 | 2761 tem = read0 (readcharfun); |
771 | 2762 unbind_to (speccount); |
428 | 2763 return list2 (Qbackquote, tem); |
2764 } | |
2765 | |
2766 case ',': | |
2767 { | |
2768 if (new_backquote_flag) | |
2769 { | |
2770 Lisp_Object comma_type = Qnil; | |
2771 int ch = readchar (readcharfun); | |
2772 | |
2773 if (ch == '@') | |
2774 comma_type = Qcomma_at; | |
2775 else if (ch == '.') | |
2776 comma_type = Qcomma_dot; | |
2777 else | |
2778 { | |
2779 if (ch >= 0) | |
2780 unreadchar (readcharfun, ch); | |
2781 comma_type = Qcomma; | |
2782 } | |
2783 return list2 (comma_type, read0 (readcharfun)); | |
2784 } | |
2785 else | |
2786 { | |
2787 /* YUCK. 99.999% backwards compatibility. The Right | |
2788 Thing(tm) is to signal an error here, because it's | |
2789 really invalid read syntax. Instead, this permits | |
2790 commas to begin symbols (unless they're inside | |
2791 backquotes). If an error is signalled here in the | |
2792 future, then commas should be invalid read syntax | |
2793 outside of backquotes anywhere they're found (i.e. | |
2794 they must be quoted in symbols) -- Stig */ | |
2795 return read_atom (readcharfun, c, 0); | |
2796 } | |
2797 } | |
2798 #endif | |
2799 | |
2800 case '?': | |
2801 { | |
2802 /* Evil GNU Emacs "character" (ie integer) syntax */ | |
2803 c = readchar (readcharfun); | |
2804 if (c < 0) | |
2805 return Fsignal (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun))); | |
2806 | |
2807 if (c == '\\') | |
2808 c = read_escape (readcharfun); | |
4439 | 2809 if (c < 0) |
2810 return Fsignal (Qinvalid_read_syntax, list1 (READCHARFUN_MAYBE (readcharfun))); | |
428 | 2811 return make_char (c); |
2812 } | |
2813 | |
2814 case '\"': | |
3543 | 2815 /* String */ |
2816 return read_string(readcharfun, '\"', 0, 1); | |
428 | 2817 |
2818 default: | |
2819 { | |
2820 /* Ignore whitespace and control characters */ | |
2821 if (c <= 040) | |
2822 goto retry; | |
2823 return read_atom (readcharfun, c, 0); | |
2824 } | |
2825 } | |
2826 } | |
2827 | |
2828 | |
2829 | |
2830 #define LEAD_INT 1 | |
2831 #define DOT_CHAR 2 | |
2832 #define TRAIL_INT 4 | |
2833 #define E_CHAR 8 | |
2834 #define EXP_INT 16 | |
2835 | |
2836 int | |
442 | 2837 isfloat_string (const char *cp) |
428 | 2838 { |
2839 int state = 0; | |
867 | 2840 const Ibyte *ucp = (const Ibyte *) cp; |
428 | 2841 |
2842 if (*ucp == '+' || *ucp == '-') | |
2843 ucp++; | |
2844 | |
2845 if (*ucp >= '0' && *ucp <= '9') | |
2846 { | |
2847 state |= LEAD_INT; | |
2848 while (*ucp >= '0' && *ucp <= '9') | |
2849 ucp++; | |
2850 } | |
2851 if (*ucp == '.') | |
2852 { | |
2853 state |= DOT_CHAR; | |
2854 ucp++; | |
2855 } | |
2856 if (*ucp >= '0' && *ucp <= '9') | |
2857 { | |
2858 state |= TRAIL_INT; | |
2859 while (*ucp >= '0' && *ucp <= '9') | |
2860 ucp++; | |
2861 } | |
2862 if (*ucp == 'e' || *ucp == 'E') | |
2863 { | |
2864 state |= E_CHAR; | |
2865 ucp++; | |
2866 if ((*ucp == '+') || (*ucp == '-')) | |
2867 ucp++; | |
2868 } | |
2869 | |
2870 if (*ucp >= '0' && *ucp <= '9') | |
2871 { | |
2872 state |= EXP_INT; | |
2873 while (*ucp >= '0' && *ucp <= '9') | |
2874 ucp++; | |
2875 } | |
2876 return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') || (*ucp == '\n') | |
2877 || (*ucp == '\r') || (*ucp == '\f')) | |
2878 && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT) | |
2879 || state == (DOT_CHAR|TRAIL_INT) | |
2880 || state == (LEAD_INT|E_CHAR|EXP_INT) | |
2881 || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT) | |
2882 || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT))); | |
2883 } | |
1983 | 2884 |
2885 #ifdef HAVE_RATIO | |
2886 int | |
2887 isratio_string (const char *cp) | |
2888 { | |
2010 | 2889 /* Possible minus/plus sign */ |
2890 if (*cp == '-' || *cp == '+') | |
1983 | 2891 cp++; |
2892 | |
2893 /* Numerator */ | |
2894 if (*cp < '0' || *cp > '9') | |
2895 return 0; | |
2896 | |
2897 do { | |
2898 cp++; | |
2899 } while (*cp >= '0' && *cp <= '9'); | |
2900 | |
2901 /* Slash */ | |
2902 if (*cp++ != '/') | |
2903 return 0; | |
2904 | |
2905 /* Denominator */ | |
2906 if (*cp < '0' || *cp > '9') | |
2907 return 0; | |
2908 | |
2909 do { | |
2910 cp++; | |
2911 } while (*cp >= '0' && *cp <= '9'); | |
2912 | |
2913 return *cp == '\0' || *cp == ' ' || *cp =='\t' || *cp == '\n' || | |
2914 *cp == '\r' || *cp == '\f'; | |
2915 } | |
2916 #endif | |
428 | 2917 |
2918 static void * | |
2919 sequence_reader (Lisp_Object readcharfun, | |
867 | 2920 Ichar terminator, |
428 | 2921 void *state, |
2922 void * (*conser) (Lisp_Object readcharfun, | |
2923 void *state, Charcount len)) | |
2924 { | |
2925 Charcount len; | |
2926 | |
2927 for (len = 0; ; len++) | |
2928 { | |
867 | 2929 Ichar ch; |
428 | 2930 |
2931 QUIT; | |
2932 ch = reader_nextchar (readcharfun); | |
2933 | |
2934 if (ch == terminator) | |
2935 return state; | |
2936 else | |
2937 unreadchar (readcharfun, ch); | |
2938 #ifdef FEATUREP_SYNTAX | |
2939 if (ch == ']') | |
442 | 2940 read_syntax_error ("\"]\" in a list"); |
428 | 2941 else if (ch == ')') |
442 | 2942 read_syntax_error ("\")\" in a vector"); |
428 | 2943 #endif |
2944 state = ((conser) (readcharfun, state, len)); | |
2945 } | |
2946 } | |
2947 | |
2948 | |
2949 struct read_list_state | |
2950 { | |
2951 Lisp_Object head; | |
2952 Lisp_Object tail; | |
2953 int length; | |
2954 int allow_dotted_lists; | |
867 | 2955 Ichar terminator; |
428 | 2956 }; |
2957 | |
2958 static void * | |
2286 | 2959 read_list_conser (Lisp_Object readcharfun, void *state, Charcount UNUSED (len)) |
428 | 2960 { |
2961 struct read_list_state *s = (struct read_list_state *) state; | |
2962 Lisp_Object elt; | |
2963 | |
2964 elt = read1 (readcharfun); | |
2965 | |
2966 if (CONSP (elt) && UNBOUNDP (XCAR (elt))) | |
2967 { | |
2968 Lisp_Object tem = elt; | |
867 | 2969 Ichar ch; |
428 | 2970 |
2971 elt = XCDR (elt); | |
853 | 2972 free_cons (tem); |
428 | 2973 tem = Qnil; |
2974 ch = XCHAR (elt); | |
2975 #ifdef FEATUREP_SYNTAX | |
2976 if (ch == s->terminator) /* deal with #+, #- reader macros */ | |
2977 { | |
2978 unreadchar (readcharfun, s->terminator); | |
2979 goto done; | |
2980 } | |
2981 else if (ch == ']') | |
442 | 2982 read_syntax_error ("']' in a list"); |
428 | 2983 else if (ch == ')') |
442 | 2984 read_syntax_error ("')' in a vector"); |
428 | 2985 else |
2986 #endif | |
2987 if (ch != '.') | |
563 | 2988 signal_error (Qinternal_error, "BUG! Internal reader error", elt); |
428 | 2989 else if (!s->allow_dotted_lists) |
442 | 2990 read_syntax_error ("\".\" in a vector"); |
428 | 2991 else |
2992 { | |
2993 if (!NILP (s->tail)) | |
2994 XCDR (s->tail) = read0 (readcharfun); | |
2995 else | |
2996 s->head = read0 (readcharfun); | |
2997 elt = read1 (readcharfun); | |
2998 if (CONSP (elt) && UNBOUNDP (XCAR (elt))) | |
2999 { | |
3000 ch = XCHAR (XCDR (elt)); | |
853 | 3001 free_cons (elt); |
428 | 3002 if (ch == s->terminator) |
3003 { | |
3004 unreadchar (readcharfun, s->terminator); | |
3005 goto done; | |
3006 } | |
3007 } | |
442 | 3008 read_syntax_error (". in wrong context"); |
428 | 3009 } |
3010 } | |
3011 | |
3012 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
3013 if (s->length == 1 && s->allow_dotted_lists && EQ (XCAR (s->head), Qfset)) | |
3014 { | |
3015 if (CONSP (elt) && EQ (XCAR (elt), Qquote) && CONSP (XCDR (elt))) | |
3016 Vcurrent_compiled_function_annotation = XCAR (XCDR (elt)); | |
3017 else | |
3018 Vcurrent_compiled_function_annotation = elt; | |
3019 } | |
3020 #endif | |
3021 | |
3022 elt = Fcons (elt, Qnil); | |
3023 if (!NILP (s->tail)) | |
3024 XCDR (s->tail) = elt; | |
3025 else | |
3026 s->head = elt; | |
3027 s->tail = elt; | |
3028 done: | |
3029 s->length++; | |
3030 return s; | |
3031 } | |
3032 | |
3033 | |
814 | 3034 /* allow_dotted_lists means that something like (foo bar . baz) |
3035 is acceptable. If -1, means check for starting with defun | |
3036 and make structure pure. (not implemented, probably for very | |
3037 good reasons) | |
3038 | |
3039 If check_for_doc_references, look for (#$ . INT) doc references | |
3040 in the list and record if load_force_doc_strings is non-zero. | |
3041 (Such doc references will be destroyed during the loadup phase | |
3042 by replacing with Qzero, because Snarf-documentation will fill | |
3043 them in again.) | |
3044 | |
3045 WARNING: If you set this, you sure as hell better not call | |
3046 free_list() on the returned list here. | |
3047 */ | |
428 | 3048 |
3049 static Lisp_Object | |
3050 read_list (Lisp_Object readcharfun, | |
867 | 3051 Ichar terminator, |
428 | 3052 int allow_dotted_lists, |
3053 int check_for_doc_references) | |
3054 { | |
3055 struct read_list_state s; | |
3056 struct gcpro gcpro1, gcpro2; | |
3057 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
3058 Lisp_Object old_compiled_function_annotation = | |
3059 Vcurrent_compiled_function_annotation; | |
3060 #endif | |
3061 | |
3062 s.head = Qnil; | |
3063 s.tail = Qnil; | |
3064 s.length = 0; | |
3065 s.allow_dotted_lists = allow_dotted_lists; | |
3066 s.terminator = terminator; | |
3067 GCPRO2 (s.head, s.tail); | |
3068 | |
3069 sequence_reader (readcharfun, terminator, &s, read_list_conser); | |
3070 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
3071 Vcurrent_compiled_function_annotation = old_compiled_function_annotation; | |
3072 #endif | |
3073 | |
3074 if ((purify_flag || load_force_doc_strings) && check_for_doc_references) | |
3075 { | |
3076 /* check now for any doc string references and record them | |
3077 for later. */ | |
3078 Lisp_Object tail; | |
3079 | |
3080 /* We might be dealing with an imperfect list so don't | |
3081 use LIST_LOOP */ | |
3082 for (tail = s.head; CONSP (tail); tail = XCDR (tail)) | |
3083 { | |
3084 Lisp_Object holding_cons = Qnil; | |
3085 | |
3086 { | |
3087 Lisp_Object elem = XCAR (tail); | |
3088 /* elem might be (#$ . INT) ... */ | |
3089 if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal)) | |
3090 holding_cons = tail; | |
3091 /* or it might be (quote (#$ . INT)) i.e. | |
3092 (quote . ((#$ . INT) . nil)) in the case of | |
3093 `autoload' (autoload evaluates its arguments, while | |
3094 `defvar', `defun', etc. don't). */ | |
3095 if (CONSP (elem) && EQ (XCAR (elem), Qquote) | |
3096 && CONSP (XCDR (elem))) | |
3097 { | |
3098 elem = XCAR (XCDR (elem)); | |
3099 if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal)) | |
3100 holding_cons = XCDR (XCAR (tail)); | |
3101 } | |
3102 } | |
3103 | |
3104 if (CONSP (holding_cons)) | |
3105 { | |
3106 if (purify_flag) | |
3107 { | |
3108 if (NILP (Vinternal_doc_file_name)) | |
3109 /* We have not yet called Snarf-documentation, so | |
3110 assume this file is described in the DOC file | |
3111 and Snarf-documentation will fill in the right | |
3112 value later. For now, replace the whole list | |
3113 with 0. */ | |
3114 XCAR (holding_cons) = Qzero; | |
3115 else | |
3116 /* We have already called Snarf-documentation, so | |
3117 make a relative file name for this file, so it | |
3118 can be found properly in the installed Lisp | |
3119 directory. We don't use Fexpand_file_name | |
3120 because that would make the directory absolute | |
3121 now. */ | |
3122 XCAR (XCAR (holding_cons)) = | |
3123 concat2 (build_string ("../lisp/"), | |
3124 Ffile_name_nondirectory | |
3125 (Vload_file_name_internal)); | |
3126 } | |
3127 else | |
3128 /* Not pure. Just add to Vload_force_doc_string_list, | |
3129 and the string will be filled in properly in | |
3130 load_force_doc_string_unwind(). */ | |
3131 Vload_force_doc_string_list = | |
3132 /* We pass the cons that holds the (#$ . INT) so we | |
3133 can modify it in-place. */ | |
3134 Fcons (holding_cons, Vload_force_doc_string_list); | |
3135 } | |
3136 } | |
3137 } | |
3138 | |
3139 UNGCPRO; | |
3140 return s.head; | |
3141 } | |
3142 | |
3143 static Lisp_Object | |
3144 read_vector (Lisp_Object readcharfun, | |
867 | 3145 Ichar terminator) |
428 | 3146 { |
3147 Lisp_Object tem; | |
3148 Lisp_Object *p; | |
3149 int len; | |
3150 int i; | |
3151 struct read_list_state s; | |
3152 struct gcpro gcpro1, gcpro2; | |
3153 | |
3154 s.head = Qnil; | |
3155 s.tail = Qnil; | |
3156 s.length = 0; | |
3157 s.allow_dotted_lists = 0; | |
3158 GCPRO2 (s.head, s.tail); | |
3159 | |
3160 sequence_reader (readcharfun, terminator, &s, read_list_conser); | |
3161 | |
3162 UNGCPRO; | |
3163 tem = s.head; | |
3164 len = XINT (Flength (tem)); | |
3165 | |
814 | 3166 s.head = make_vector (len, Qnil); |
428 | 3167 |
3168 for (i = 0, p = &(XVECTOR_DATA (s.head)[0]); | |
3169 i < len; | |
3170 i++, p++) | |
3171 { | |
853 | 3172 Lisp_Object otem = tem; |
428 | 3173 tem = Fcar (tem); |
3174 *p = tem; | |
853 | 3175 tem = XCDR (otem); |
428 | 3176 free_cons (otem); |
3177 } | |
3178 return s.head; | |
3179 } | |
3180 | |
3181 static Lisp_Object | |
867 | 3182 read_compiled_function (Lisp_Object readcharfun, Ichar terminator) |
428 | 3183 { |
3184 /* Accept compiled functions at read-time so that we don't | |
3185 have to build them at load-time. */ | |
3186 Lisp_Object stuff; | |
3187 Lisp_Object make_byte_code_args[COMPILED_DOMAIN + 1]; | |
3188 struct gcpro gcpro1; | |
3189 int len; | |
3190 int iii; | |
3191 int saw_a_doc_ref = 0; | |
3192 | |
3193 /* Note: we tell read_list not to search for doc references | |
3194 because we need to handle the "doc reference" for the | |
3195 instructions and constants differently. */ | |
3196 stuff = read_list (readcharfun, terminator, 0, 0); | |
3197 len = XINT (Flength (stuff)); | |
3198 if (len < COMPILED_STACK_DEPTH + 1 || len > COMPILED_DOMAIN + 1) | |
3199 return | |
442 | 3200 continuable_read_syntax_error ("#[...] used with wrong number of elements"); |
428 | 3201 |
3202 for (iii = 0; CONSP (stuff); iii++) | |
3203 { | |
853 | 3204 Lisp_Object victim = stuff; |
428 | 3205 make_byte_code_args[iii] = Fcar (stuff); |
3206 if ((purify_flag || load_force_doc_strings) | |
3207 && CONSP (make_byte_code_args[iii]) | |
3208 && EQ (XCAR (make_byte_code_args[iii]), Vload_file_name_internal)) | |
3209 { | |
3210 if (purify_flag && iii == COMPILED_DOC_STRING) | |
3211 { | |
3212 /* same as in read_list(). */ | |
3213 if (NILP (Vinternal_doc_file_name)) | |
3214 make_byte_code_args[iii] = Qzero; | |
3215 else | |
3216 XCAR (make_byte_code_args[iii]) = | |
3217 concat2 (build_string ("../lisp/"), | |
3218 Ffile_name_nondirectory | |
3219 (Vload_file_name_internal)); | |
3220 } | |
3221 else | |
3222 saw_a_doc_ref = 1; | |
3223 } | |
3224 stuff = Fcdr (stuff); | |
3225 free_cons (victim); | |
3226 } | |
3227 GCPRO1 (make_byte_code_args[0]); | |
3228 gcpro1.nvars = len; | |
3229 | |
3230 /* v18 or v19 bytecode file. Need to Ebolify. */ | |
3231 if (load_byte_code_version < 20 && VECTORP (make_byte_code_args[2])) | |
3232 ebolify_bytecode_constants (make_byte_code_args[2]); | |
3233 | |
3234 /* make-byte-code looks at purify_flag, which should have the same | |
3235 * value as our "read-pure" argument */ | |
3236 stuff = Fmake_byte_code (len, make_byte_code_args); | |
3237 XCOMPILED_FUNCTION (stuff)->flags.ebolified = (load_byte_code_version < 20); | |
3238 if (saw_a_doc_ref) | |
3239 Vload_force_doc_string_list = Fcons (stuff, Vload_force_doc_string_list); | |
3240 UNGCPRO; | |
3241 return stuff; | |
3242 } | |
3243 | |
3244 | |
3245 | |
3246 void | |
3247 init_lread (void) | |
3248 { | |
3249 Vvalues = Qnil; | |
3250 | |
3251 load_in_progress = 0; | |
3252 | |
3253 Vload_descriptor_list = Qnil; | |
3254 | |
3255 /* kludge: locate-file does not work for a null load-path, even if | |
3256 the file name is absolute. */ | |
3257 | |
3258 Vload_path = Fcons (build_string (""), Qnil); | |
3259 | |
3260 /* This used to get initialized in init_lread because all streams | |
3261 got closed when dumping occurs. This is no longer true -- | |
3262 Vread_buffer_stream is a resizing output stream, and there is no | |
3263 reason to close it at dump-time. | |
3264 | |
3265 Vread_buffer_stream is set to Qnil in vars_of_lread, and this | |
3266 will initialize it only once, at dump-time. */ | |
3267 if (NILP (Vread_buffer_stream)) | |
3268 Vread_buffer_stream = make_resizing_buffer_output_stream (); | |
3269 | |
3270 Vload_force_doc_string_list = Qnil; | |
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
3271 |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
3272 Vload_file_name_internal = Qnil; |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4483
diff
changeset
|
3273 Vload_file_name = Qnil; |
428 | 3274 } |
3275 | |
3276 void | |
3277 syms_of_lread (void) | |
3278 { | |
3279 DEFSUBR (Fread); | |
3280 DEFSUBR (Fread_from_string); | |
3281 DEFSUBR (Fload_internal); | |
3282 DEFSUBR (Flocate_file); | |
3283 DEFSUBR (Flocate_file_clear_hashing); | |
3284 DEFSUBR (Feval_buffer); | |
3285 DEFSUBR (Feval_region); | |
3286 | |
563 | 3287 DEFSYMBOL (Qstandard_input); |
3288 DEFSYMBOL (Qread_char); | |
3289 DEFSYMBOL (Qload); | |
1292 | 3290 DEFSYMBOL (Qload_internal); |
563 | 3291 DEFSYMBOL (Qfset); |
428 | 3292 |
3293 #ifdef LISP_BACKQUOTES | |
563 | 3294 DEFSYMBOL (Qbackquote); |
428 | 3295 defsymbol (&Qbacktick, "`"); |
3296 defsymbol (&Qcomma, ","); | |
3297 defsymbol (&Qcomma_at, ",@"); | |
3298 defsymbol (&Qcomma_dot, ",."); | |
3299 #endif | |
3300 | |
563 | 3301 DEFSYMBOL (Qexists); |
3302 DEFSYMBOL (Qreadable); | |
3303 DEFSYMBOL (Qwritable); | |
3304 DEFSYMBOL (Qexecutable); | |
428 | 3305 } |
3306 | |
3307 void | |
3308 structure_type_create (void) | |
3309 { | |
3310 the_structure_type_dynarr = Dynarr_new (structure_type); | |
3311 } | |
3312 | |
3313 void | |
3314 reinit_vars_of_lread (void) | |
3315 { | |
3316 Vread_buffer_stream = Qnil; | |
3317 staticpro_nodump (&Vread_buffer_stream); | |
3318 } | |
3319 | |
3320 void | |
3321 vars_of_lread (void) | |
3322 { | |
3323 DEFVAR_LISP ("values", &Vvalues /* | |
3324 List of values of all expressions which were read, evaluated and printed. | |
3325 Order is reverse chronological. | |
3326 */ ); | |
3327 | |
3328 DEFVAR_LISP ("standard-input", &Vstandard_input /* | |
3329 Stream for read to get input from. | |
3330 See documentation of `read' for possible values. | |
3331 */ ); | |
3332 Vstandard_input = Qt; | |
3333 | |
3334 DEFVAR_LISP ("load-path", &Vload_path /* | |
3335 *List of directories to search for files to load. | |
3336 Each element is a string (directory name) or nil (try default directory). | |
3337 | |
3338 Note that the elements of this list *may not* begin with "~", so you must | |
3339 call `expand-file-name' on them before adding them to this list. | |
3340 | |
3341 Initialized based on EMACSLOADPATH environment variable, if any, | |
3342 otherwise to default specified in by file `paths.h' when XEmacs was built. | |
3343 If there were no paths specified in `paths.h', then XEmacs chooses a default | |
3344 value for this variable by looking around in the file-system near the | |
3345 directory in which the XEmacs executable resides. | |
3346 */ ); | |
3347 Vload_path = Qnil; | |
3348 | |
3349 /* xxxDEFVAR_LISP ("dump-load-path", &Vdump_load_path, | |
3350 "*Location of lisp files to be used when dumping ONLY."); */ | |
3351 | |
3352 DEFVAR_BOOL ("load-in-progress", &load_in_progress /* | |
3353 Non-nil iff inside of `load'. | |
3354 */ ); | |
3355 | |
2548 | 3356 DEFVAR_LISP ("load-suppress-alist", &Vload_suppress_alist /* |
3357 An alist of expressions controlling whether particular files can be loaded. | |
3358 Each element looks like (FILENAME EXPR). | |
3359 FILENAME should be a full pathname, but without the .el suffix. | |
3360 When `load' is run and is about to load the specified file, it evaluates | |
3361 the form to determine if the file can be loaded. | |
3362 This variable is normally initialized automatically. | |
3363 */ ); | |
3364 Vload_suppress_alist = Qnil; | |
3365 | |
428 | 3366 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist /* |
3367 An alist of expressions to be evalled when particular files are loaded. | |
3368 Each element looks like (FILENAME FORMS...). | |
3369 When `load' is run and the file-name argument is FILENAME, | |
3370 the FORMS in the corresponding element are executed at the end of loading. | |
3371 | |
3372 FILENAME must match exactly! Normally FILENAME is the name of a library, | |
3373 with no directory specified, since that is how `load' is normally called. | |
3374 An error in FORMS does not undo the load, | |
3375 but does prevent execution of the rest of the FORMS. | |
3376 */ ); | |
3377 Vafter_load_alist = Qnil; | |
3378 | |
3379 DEFVAR_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer /* | |
3380 *Whether `load' should check whether the source is newer than the binary. | |
3381 If this variable is true, then when a `.elc' file is being loaded and the | |
3382 corresponding `.el' is newer, a warning message will be printed. | |
3383 */ ); | |
1261 | 3384 load_warn_when_source_newer = 1; |
428 | 3385 |
3386 DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only /* | |
3387 *Whether `load' should warn when loading a `.el' file instead of an `.elc'. | |
3388 If this variable is true, then when `load' is called with a filename without | |
3389 an extension, and the `.elc' version doesn't exist but the `.el' version does, | |
3390 then a message will be printed. If an explicit extension is passed to `load', | |
3391 no warning will be printed. | |
3392 */ ); | |
3393 load_warn_when_source_only = 0; | |
3394 | |
3395 DEFVAR_BOOL ("load-ignore-elc-files", &load_ignore_elc_files /* | |
3396 *Whether `load' should ignore `.elc' files when a suffix is not given. | |
3397 This is normally used only to bootstrap the `.elc' files when building XEmacs. | |
3398 */ ); | |
3399 load_ignore_elc_files = 0; | |
3400 | |
1123 | 3401 DEFVAR_BOOL ("load-ignore-out-of-date-elc-files", |
3402 &load_ignore_out_of_date_elc_files /* | |
3403 *Whether `load' should ignore out-of-date `.elc' files when no suffix is given. | |
3404 This is normally used when compiling packages of elisp files that may have | |
3405 complex dependencies. Ignoring all elc files with `load-ignore-elc-files' | |
3406 would also be safe, but much slower. | |
3407 */ ); | |
3408 load_ignore_out_of_date_elc_files = 0; | |
3409 | |
3410 DEFVAR_BOOL ("load-always-display-messages", | |
3411 &load_always_display_messages /* | |
3412 *Whether `load' should always display loading messages. | |
3413 If this is true, every file loaded will be shown, regardless of the setting | |
3414 of the NOMESSAGE parameter, and even when files are loaded indirectly, e.g. | |
2857 | 3415 due to `require'. |
1123 | 3416 */ ); |
3417 load_always_display_messages = 0; | |
3418 | |
3419 DEFVAR_BOOL ("load-show-full-path-in-messages", | |
3420 &load_show_full_path_in_messages /* | |
3421 *Whether `load' should show the full path in all loading messages. | |
3422 */ ); | |
3423 load_show_full_path_in_messages = 0; | |
3424 | |
428 | 3425 #ifdef LOADHIST |
3426 DEFVAR_LISP ("load-history", &Vload_history /* | |
3427 Alist mapping source file names to symbols and features. | |
3428 Each alist element is a list that starts with a file name, | |
3429 except for one element (optional) that starts with nil and describes | |
3430 definitions evaluated from buffers not visiting files. | |
3431 The remaining elements of each list are symbols defined as functions | |
3432 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'. | |
3433 */ ); | |
3434 Vload_history = Qnil; | |
3435 | |
3436 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list /* | |
3437 Used for internal purposes by `load'. | |
3438 */ ); | |
3439 Vcurrent_load_list = Qnil; | |
3440 #endif | |
3441 | |
3442 DEFVAR_LISP ("load-file-name", &Vload_file_name /* | |
3443 Full name of file being loaded by `load'. | |
3444 */ ); | |
3445 Vload_file_name = Qnil; | |
3446 | |
3447 DEFVAR_LISP ("load-read-function", &Vload_read_function /* | |
3448 Function used by `load' and `eval-region' for reading expressions. | |
3449 The default is nil, which means use the function `read'. | |
3450 */ ); | |
3451 Vload_read_function = Qnil; | |
3452 | |
3453 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings /* | |
3454 Non-nil means `load' should force-load all dynamic doc strings. | |
3455 This is useful when the file being loaded is a temporary copy. | |
3456 */ ); | |
3457 load_force_doc_strings = 0; | |
3458 | |
3459 /* See read_escape(). */ | |
3460 #if 0 | |
3461 /* Used to be named `puke-on-fsf-keys' */ | |
3462 DEFVAR_BOOL ("fail-on-bucky-bit-character-escapes", | |
3463 &fail_on_bucky_bit_character_escapes /* | |
3464 Whether `read' should signal an error when it encounters unsupported | |
3465 character escape syntaxes or just read them incorrectly. | |
3466 */ ); | |
3467 fail_on_bucky_bit_character_escapes = 0; | |
3468 #endif | |
3469 | |
3470 /* This must be initialized in init_lread otherwise it may start out | |
3471 with values saved when the image is dumped. */ | |
3472 staticpro (&Vload_descriptor_list); | |
3473 | |
3474 /* Initialized in init_lread. */ | |
3475 staticpro (&Vload_force_doc_string_list); | |
3476 | |
3477 Vload_file_name_internal = Qnil; | |
3478 staticpro (&Vload_file_name_internal); | |
3479 | |
3480 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
3481 Vcurrent_compiled_function_annotation = Qnil; | |
3482 staticpro (&Vcurrent_compiled_function_annotation); | |
3483 #endif | |
3484 | |
3485 /* So that early-early stuff will work */ | |
1292 | 3486 Ffset (Qload, Qload_internal); |
428 | 3487 |
3488 #ifdef FEATUREP_SYNTAX | |
563 | 3489 DEFSYMBOL (Qfeaturep); |
771 | 3490 Fprovide (intern ("xemacs")); |
428 | 3491 #ifdef INFODOCK |
771 | 3492 Fprovide (intern ("infodock")); |
428 | 3493 #endif /* INFODOCK */ |
3494 #endif /* FEATUREP_SYNTAX */ | |
3495 | |
3496 #ifdef LISP_BACKQUOTES | |
3497 old_backquote_flag = new_backquote_flag = 0; | |
3498 #endif | |
3499 | |
3500 #ifdef I18N3 | |
3501 Vfile_domain = Qnil; | |
3502 #endif | |
3503 | |
3504 Vread_objects = Qnil; | |
3505 staticpro (&Vread_objects); | |
3506 | |
3507 Vlocate_file_hash_table = make_lisp_hash_table (200, | |
3508 HASH_TABLE_NON_WEAK, | |
3509 HASH_TABLE_EQUAL); | |
3510 staticpro (&Vlocate_file_hash_table); | |
3511 #ifdef DEBUG_XEMACS | |
3512 symbol_value (XSYMBOL (intern ("Vlocate-file-hash-table"))) | |
3513 = Vlocate_file_hash_table; | |
3514 #endif | |
3515 } |