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