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