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