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