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