import xemacs-21.2.37
[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 read_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_read_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         {
263           if (c >= 0x20 && c <= 0x7E) stderr_out ("%c", c);
264           else if (c == '\n')         stderr_out ("\\n\n");
265           else                        stderr_out ("\\%o ", c);
266         }
267 #endif /* testing Mule */
268       return c;
269     }
270   else if (MARKERP (readcharfun))
271     {
272       Emchar c;
273       Bufpos mpos = marker_position (readcharfun);
274       struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
275
276       if (mpos >= BUF_ZV (inbuffer))
277         return -1;
278       c = BUF_FETCH_CHAR (inbuffer, mpos);
279       set_marker_position (readcharfun, mpos + 1);
280       return c;
281     }
282   else
283     {
284       Lisp_Object tem = call0 (readcharfun);
285
286       if (!CHAR_OR_CHAR_INTP (tem))
287         return -1;
288       return XCHAR_OR_CHAR_INT (tem);
289     }
290 }
291
292 /* Unread the character C in the way appropriate for the stream READCHARFUN.
293    If the stream is a user function, call it with the char as argument.  */
294
295 static void
296 unreadchar (Lisp_Object readcharfun, Emchar c)
297 {
298   if (c == -1)
299     /* Don't back up the pointer if we're unreading the end-of-input mark,
300        since readchar didn't advance it when we read it.  */
301     ;
302   else if (BUFFERP (readcharfun))
303     BUF_SET_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1);
304   else if (LSTREAMP (readcharfun))
305     {
306       Lstream_unget_emchar (XLSTREAM (readcharfun), c);
307 #ifdef DEBUG_XEMACS /* testing Mule */
308       {
309         static int testing_mule = 0; /* Set this using debugger */
310         if (testing_mule)
311           fprintf (stderr,
312                    (c >= 0x20 && c <= 0x7E) ? "UU%c" :
313                    ((c == '\n') ? "UU\\n\n" : "UU\\%o"), c);
314       }
315 #endif
316     }
317   else if (MARKERP (readcharfun))
318     set_marker_position (readcharfun, marker_position (readcharfun) - 1);
319   else
320     call1 (readcharfun, make_char (c));
321 }
322
323 static Lisp_Object read0 (Lisp_Object readcharfun);
324 static Lisp_Object read1 (Lisp_Object readcharfun);
325 /* allow_dotted_lists means that something like (foo bar . baz)
326    is acceptable.  If -1, means check for starting with defun
327    and make structure pure. (not implemented, probably for very
328    good reasons)
329 */
330 /*
331    If check_for_doc_references, look for (#$ . INT) doc references
332    in the list and record if load_force_doc_strings is non-zero.
333    (Such doc references will be destroyed during the loadup phase
334    by replacing with Qzero, because Snarf-documentation will fill
335    them in again.)
336
337    WARNING: If you set this, you sure as hell better not call
338    free_list() on the returned list here. */
339
340 static Lisp_Object read_list (Lisp_Object readcharfun,
341                               Emchar terminator,
342                               int allow_dotted_lists,
343                               int check_for_doc_references);
344 \f
345 static void readevalloop (Lisp_Object readcharfun,
346                           Lisp_Object sourcefile,
347                           Lisp_Object (*evalfun) (Lisp_Object),
348                           int printflag);
349
350 static Lisp_Object
351 load_unwind (Lisp_Object stream)  /* used as unwind-protect function in load */
352 {
353   Lstream_close (XLSTREAM (stream));
354   if (--load_in_progress < 0)
355     load_in_progress = 0;
356   return Qnil;
357 }
358
359 static Lisp_Object
360 load_descriptor_unwind (Lisp_Object oldlist)
361 {
362   Vload_descriptor_list = oldlist;
363   return Qnil;
364 }
365
366 static Lisp_Object
367 load_file_name_internal_unwind (Lisp_Object oldval)
368 {
369   Vload_file_name_internal = oldval;
370   return Qnil;
371 }
372
373 static Lisp_Object
374 load_file_name_internal_the_purecopy_unwind (Lisp_Object oldval)
375 {
376   Vload_file_name_internal_the_purecopy = oldval;
377   return Qnil;
378 }
379
380 static Lisp_Object
381 load_byte_code_version_unwind (Lisp_Object oldval)
382 {
383   load_byte_code_version = XINT (oldval);
384   return Qnil;
385 }
386
387 /* The plague is coming.
388
389    Ring around the rosy, pocket full of posy,
390    Ashes ashes, they all fall down.
391    */
392 void
393 ebolify_bytecode_constants (Lisp_Object vector)
394 {
395   int len = XVECTOR_LENGTH (vector);
396   int i;
397
398   for (i = 0; i < len; i++)
399     {
400       Lisp_Object el = XVECTOR_DATA (vector)[i];
401
402       /* We don't check for `eq', `equal', and the others that have
403          bytecode opcodes.  This might lose if someone passes #'eq or
404          something to `funcall', but who would really do that?  As
405          they say in law, we've made a "good-faith effort" to
406          unfuckify ourselves.  And doing it this way avoids screwing
407          up args to `make-hash-table' and such.  As it is, we have to
408          add an extra Ebola check in decode_weak_list_type(). --ben */
409       if      (EQ (el, Qassoc))  el = Qold_assoc;
410       else if (EQ (el, Qdelq))   el = Qold_delq;
411 #if 0
412       /* I think this is a bad idea because it will probably mess
413          with keymap code. */
414       else if (EQ (el, Qdelete)) el = Qold_delete;
415 #endif
416       else if (EQ (el, Qrassq))  el = Qold_rassq;
417       else if (EQ (el, Qrassoc)) el = Qold_rassoc;
418
419       XVECTOR_DATA (vector)[i] = el;
420     }
421 }
422
423 static Lisp_Object
424 pas_de_lache_ici (int fd, Lisp_Object victim)
425 {
426   Lisp_Object tem;
427   EMACS_INT pos;
428
429   if (!INTP (XCDR (victim)))
430     signal_simple_error ("Bogus doc string reference", victim);
431   pos = XINT (XCDR (victim));
432   if (pos < 0)
433     pos = -pos; /* kludge to mark a user variable */
434   tem = unparesseuxify_doc_string (fd, pos, 0, Vload_file_name_internal);
435   if (!STRINGP (tem))
436     signal_error (Qerror, tem);
437   return tem;
438 }
439
440 static Lisp_Object
441 load_force_doc_string_unwind (Lisp_Object oldlist)
442 {
443   struct gcpro gcpro1;
444   Lisp_Object list = Vload_force_doc_string_list;
445   Lisp_Object tail;
446   int fd = XINT (XCAR (Vload_descriptor_list));
447
448   GCPRO1 (list);
449   /* restore the old value first just in case an error occurs. */
450   Vload_force_doc_string_list = oldlist;
451
452   LIST_LOOP (tail, list)
453     {
454       Lisp_Object john = Fcar (tail);
455       if (CONSP (john))
456         {
457           assert (CONSP (XCAR (john)));
458           assert (!purify_flag); /* should have been handled in read_list() */
459           XCAR (john) = pas_de_lache_ici (fd, XCAR (john));
460         }
461       else
462         {
463           Lisp_Object doc;
464
465           assert (COMPILED_FUNCTIONP (john));
466           if (CONSP (XCOMPILED_FUNCTION (john)->instructions))
467             {
468               struct gcpro ngcpro1;
469               Lisp_Object juan = (pas_de_lache_ici
470                                   (fd, XCOMPILED_FUNCTION (john)->instructions));
471               Lisp_Object ivan;
472
473               NGCPRO1 (juan);
474               ivan = Fread (juan);
475               if (!CONSP (ivan))
476                 signal_simple_error ("invalid lazy-loaded byte code", ivan);
477               XCOMPILED_FUNCTION (john)->instructions = XCAR (ivan);
478               /* v18 or v19 bytecode file.  Need to Ebolify. */
479               if (XCOMPILED_FUNCTION (john)->flags.ebolified
480                   && VECTORP (XCDR (ivan)))
481                 ebolify_bytecode_constants (XCDR (ivan));
482               XCOMPILED_FUNCTION (john)->constants = XCDR (ivan);
483               NUNGCPRO;
484             }
485           doc = compiled_function_documentation (XCOMPILED_FUNCTION (john));
486           if (CONSP (doc))
487             {
488               assert (!purify_flag); /* should have been handled in
489                                         read_compiled_function() */
490               doc = pas_de_lache_ici (fd, doc);
491               set_compiled_function_documentation (XCOMPILED_FUNCTION (john),
492                                                    doc);
493             }
494         }
495     }
496
497   if (!NILP (list))
498     free_list (list);
499
500   UNGCPRO;
501   return Qnil;
502 }
503
504 /* Close all descriptors in use for Fload_internal.
505    This is used when starting a subprocess.  */
506
507 void
508 close_load_descs (void)
509 {
510   Lisp_Object tail;
511   LIST_LOOP (tail, Vload_descriptor_list)
512     close (XINT (XCAR (tail)));
513 }
514
515 #ifdef I18N3
516 Lisp_Object Vfile_domain;
517
518 Lisp_Object
519 restore_file_domain (Lisp_Object val)
520 {
521   Vfile_domain = val;
522   return Qnil;
523 }
524 #endif /* I18N3 */
525
526 DEFUN ("load-internal", Fload_internal, 1, 6, 0, /*
527 Execute a file of Lisp code named FILE; no coding-system frobbing.
528 This function is identical to `load' except for the handling of the
529 CODESYS and USED-CODESYS arguments under XEmacs/Mule. (When Mule
530 support is not present, both functions are identical and ignore the
531 CODESYS and USED-CODESYS arguments.)
532
533 If support for Mule exists in this Emacs, the file is decoded
534 according to CODESYS; if omitted, no conversion happens.  If
535 USED-CODESYS is non-nil, it should be a symbol, and the actual coding
536 system that was used for the decoding is stored into it.  It will in
537 general be different from CODESYS if CODESYS specifies automatic
538 encoding detection or end-of-line detection.
539 */
540        (file, noerror, nomessage, nosuffix, codesys, used_codesys))
541 {
542   /* This function can GC */
543   int fd = -1;
544   int speccount = specpdl_depth ();
545   int source_only = 0;
546   Lisp_Object newer   = Qnil;
547   Lisp_Object handler = Qnil;
548   Lisp_Object found   = Qnil;
549   struct gcpro gcpro1, gcpro2, gcpro3;
550   int reading_elc = 0;
551   int message_p = NILP (nomessage);
552 /*#ifdef DEBUG_XEMACS*/
553   static Lisp_Object last_file_loaded;
554 /*#endif*/
555   struct stat s1, s2;
556   GCPRO3 (file, newer, found);
557
558   CHECK_STRING (file);
559
560 /*#ifdef DEBUG_XEMACS*/
561   if (purify_flag && noninteractive)
562     {
563       message_p = 1;
564       last_file_loaded = file;
565     }
566 /*#endif / * DEBUG_XEMACS */
567
568   /* If file name is magic, call the handler.  */
569   handler = Ffind_file_name_handler (file, Qload);
570   if (!NILP (handler))
571     RETURN_UNGCPRO (call5 (handler, Qload, file, noerror,
572                           nomessage, nosuffix));
573
574   /* Do this after the handler to avoid
575      the need to gcpro noerror, nomessage and nosuffix.
576      (Below here, we care only whether they are nil or not.)  */
577   file = Fsubstitute_in_file_name (file);
578 #ifdef FILE_CODING
579   if (!NILP (used_codesys))
580     CHECK_SYMBOL (used_codesys);
581 #endif
582
583   /* Avoid weird lossage with null string as arg,
584      since it would try to load a directory as a Lisp file.
585      Unix truly sucks. */
586   if (XSTRING_LENGTH (file) > 0)
587     {
588       char *foundstr;
589       int foundlen;
590
591       fd = locate_file (Vload_path, file,
592                         ((!NILP (nosuffix)) ? Qnil :
593                          build_string (load_ignore_elc_files ? ".el:" :
594                                        ".elc:.el:")),
595                         &found,
596                         -1);
597
598       if (fd < 0)
599         {
600           if (NILP (noerror))
601             signal_file_error ("Cannot open load file", file);
602           else
603             {
604               UNGCPRO;
605               return Qnil;
606             }
607         }
608
609       foundstr = (char *) alloca (XSTRING_LENGTH (found) + 1);
610       strcpy (foundstr, (char *) XSTRING_DATA (found));
611       foundlen = strlen (foundstr);
612
613       /* The omniscient JWZ thinks this is worthless, but I beg to
614          differ. --ben */
615       if (load_ignore_elc_files)
616         {
617           newer = Ffile_name_nondirectory (found);
618         }
619       else if (load_warn_when_source_newer &&
620                !memcmp (".elc", foundstr + foundlen - 4, 4))
621         {
622           if (! fstat (fd, &s1))        /* can't fail, right? */
623             {
624               int result;
625               /* temporarily hack the 'c' off the end of the filename */
626               foundstr[foundlen - 1] = '\0';
627               result = xemacs_stat (foundstr, &s2);
628               if (result >= 0 &&
629                   (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
630               {
631                 Lisp_Object newer_name = make_string ((Bufbyte *) foundstr,
632                                                       foundlen - 1);
633                 struct gcpro nngcpro1;
634                 NNGCPRO1 (newer_name);
635                 newer = Ffile_name_nondirectory (newer_name);
636                 NNUNGCPRO;
637               }
638               /* put the 'c' back on (kludge-o-rama) */
639               foundstr[foundlen - 1] = 'c';
640             }
641         }
642       else if (load_warn_when_source_only &&
643                /* `found' ends in ".el" */
644                !memcmp (".el", foundstr + foundlen - 3, 3) &&
645                /* `file' does not end in ".el" */
646                memcmp (".el",
647                        XSTRING_DATA (file) + XSTRING_LENGTH (file) - 3,
648                        3))
649         {
650           source_only = 1;
651         }
652
653       if (!memcmp (".elc", foundstr + foundlen - 4, 4))
654         reading_elc = 1;
655     }
656
657 #define PRINT_LOADING_MESSAGE(done) do {                                \
658   if (load_ignore_elc_files)                                            \
659     {                                                                   \
660       if (message_p)                                                    \
661         message ("Loading %s..." done, XSTRING_DATA (newer));           \
662     }                                                                   \
663   else if (!NILP (newer))                                               \
664     message ("Loading %s..." done " (file %s is newer)",                \
665              XSTRING_DATA (file),                                       \
666              XSTRING_DATA (newer));                                     \
667   else if (source_only)                                                 \
668     message ("Loading %s..." done " (file %s.elc does not exist)",      \
669              XSTRING_DATA (file),                                       \
670              XSTRING_DATA (Ffile_name_nondirectory (file)));            \
671   else if (message_p)                                                   \
672     message ("Loading %s..." done, XSTRING_DATA (file));                \
673   } while (0)
674
675   PRINT_LOADING_MESSAGE ("");
676
677   {
678     /* Lisp_Object's must be malloc'ed, not stack-allocated */
679     Lisp_Object lispstream = Qnil;
680     const int block_size = 8192;
681     struct gcpro ngcpro1;
682
683     NGCPRO1 (lispstream);
684     lispstream = make_filedesc_input_stream (fd, 0, -1, LSTR_CLOSING);
685     /* 64K is used for normal files; 8K should be OK here because Lisp
686        files aren't really all that big. */
687     Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED,
688                            block_size);
689 #ifdef FILE_CODING
690     lispstream = make_decoding_input_stream
691       (XLSTREAM (lispstream), Fget_coding_system (codesys));
692     Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED,
693                            block_size);
694 #endif
695     /* NOTE: Order of these is very important.  Don't rearrange them. */
696     record_unwind_protect (load_unwind, lispstream);
697     record_unwind_protect (load_descriptor_unwind, Vload_descriptor_list);
698     record_unwind_protect (load_file_name_internal_unwind,
699                            Vload_file_name_internal);
700     record_unwind_protect (load_file_name_internal_the_purecopy_unwind,
701                            Vload_file_name_internal_the_purecopy);
702     record_unwind_protect (load_force_doc_string_unwind,
703                            Vload_force_doc_string_list);
704     Vload_file_name_internal = found;
705     Vload_file_name_internal_the_purecopy = Qnil;
706     specbind (Qload_file_name, found);
707     Vload_descriptor_list = Fcons (make_int (fd), Vload_descriptor_list);
708     Vload_force_doc_string_list = Qnil;
709 #ifdef I18N3
710     record_unwind_protect (restore_file_domain, Vfile_domain);
711     Vfile_domain = Qnil; /* set it to nil; a call to #'domain will set it. */
712 #endif
713     load_in_progress++;
714
715     /* Now determine what sort of ELC file we're reading in. */
716     record_unwind_protect (load_byte_code_version_unwind,
717                            make_int (load_byte_code_version));
718     if (reading_elc)
719       {
720         char elc_header[8];
721         int num_read;
722
723         num_read = Lstream_read (XLSTREAM (lispstream), elc_header, 8);
724         if (num_read < 8
725             || strncmp (elc_header, ";ELC", 4))
726           {
727             /* Huh?  Probably not a valid ELC file. */
728             load_byte_code_version = 100; /* no Ebolification needed */
729             Lstream_unread (XLSTREAM (lispstream), elc_header, num_read);
730           }
731         else
732           load_byte_code_version = elc_header[4];
733       }
734     else
735       load_byte_code_version = 100; /* no Ebolification needed */
736
737     readevalloop (lispstream, file, Feval, 0);
738 #ifdef FILE_CODING
739     if (!NILP (used_codesys))
740       Fset (used_codesys,
741             XCODING_SYSTEM_NAME
742             (decoding_stream_coding_system (XLSTREAM (lispstream))));
743 #endif
744     unbind_to (speccount, Qnil);
745
746     NUNGCPRO;
747   }
748
749   {
750     Lisp_Object tem;
751     /* #### Disgusting kludge */
752     /* Run any load-hooks for this file.  */
753     /* #### An even more disgusting kludge.  There is horrible code */
754     /* that is relying on the fact that dumped lisp files are found */
755     /* via `load-path' search. */
756     Lisp_Object name = file;
757
758     if (!NILP(Ffile_name_absolute_p(file)))
759       {
760         name = Ffile_name_nondirectory(file);
761       }
762
763     {
764       struct gcpro ngcpro1;
765
766       NGCPRO1 (name);
767       tem = Fassoc (name, Vafter_load_alist);
768       NUNGCPRO;
769     }
770     if (!NILP (tem))
771       {
772         struct gcpro ngcpro1;
773
774         NGCPRO1 (tem);
775         /* Use eval so that errors give a semi-meaningful backtrace.  --Stig */
776         tem = Fcons (Qprogn, Fcdr (tem));
777         Feval (tem);
778         NUNGCPRO;
779       }
780   }
781
782 /*#ifdef DEBUG_XEMACS*/
783   if (purify_flag && noninteractive)
784     {
785       if (!EQ (last_file_loaded, file))
786         message ("Loading %s ...done", XSTRING_DATA (file));
787     }
788 /*#endif / * DEBUG_XEMACS */
789
790   if (!noninteractive)
791     PRINT_LOADING_MESSAGE ("done");
792
793   UNGCPRO;
794   return Qt;
795 }
796
797 \f
798 /* ------------------------------- */
799 /*          locate_file            */
800 /* ------------------------------- */
801
802 static int
803 decode_mode_1 (Lisp_Object mode)
804 {
805   if (EQ (mode, Qexists))
806     return F_OK;
807   else if (EQ (mode, Qexecutable))
808     return X_OK;
809   else if (EQ (mode, Qwritable))
810     return W_OK;
811   else if (EQ (mode, Qreadable))
812     return R_OK;
813   else if (INTP (mode))
814     {
815       check_int_range (XINT (mode), 0, 7);
816       return XINT (mode);
817     }
818   else
819     signal_simple_error ("Invalid value", mode);
820   return 0;                     /* unreached */
821 }
822
823 static int
824 decode_mode (Lisp_Object mode)
825 {
826   if (NILP (mode))
827     return R_OK;
828   else if (CONSP (mode))
829     {
830       Lisp_Object tail;
831       int mask = 0;
832       EXTERNAL_LIST_LOOP (tail, mode)
833         mask |= decode_mode_1 (XCAR (tail));
834       return mask;
835     }
836   else
837     return decode_mode_1 (mode);
838 }
839
840 DEFUN ("locate-file", Flocate_file, 2, 4, 0, /*
841 Search for FILENAME through PATH-LIST.
842
843 If SUFFIXES is non-nil, it should be a list of suffixes to append to
844 file name when searching.
845
846 If MODE is non-nil, it should be a symbol or a list of symbol representing
847 requirements.  Allowed symbols are `exists', `executable', `writable', and
848 `readable'.  If MODE is nil, it defaults to `readable'.
849
850 `locate-file' keeps hash tables of the directories it searches through,
851 in order to speed things up.  It tries valiantly to not get confused in
852 the face of a changing and unpredictable environment, but can occasionally
853 get tripped up.  In this case, you will have to call
854 `locate-file-clear-hashing' to get it back on track.  See that function
855 for details.
856 */
857        (filename, path_list, suffixes, mode))
858 {
859   /* This function can GC */
860   Lisp_Object tp;
861
862   CHECK_STRING (filename);
863
864   if (LISTP (suffixes))
865     {
866       Lisp_Object tail;
867       EXTERNAL_LIST_LOOP (tail, suffixes)
868         CHECK_STRING (XCAR (tail));
869     }
870   else
871     CHECK_STRING (suffixes);
872
873   locate_file (path_list, filename, suffixes, &tp, decode_mode (mode));
874   return tp;
875 }
876
877 /* Recalculate the hash table for the given string.  DIRECTORY should
878    better have been through Fexpand_file_name() by now.  */
879
880 static Lisp_Object
881 locate_file_refresh_hashing (Lisp_Object directory)
882 {
883   Lisp_Object hash =
884     make_directory_hash_table ((char *) XSTRING_DATA (directory));
885
886   if (!NILP (hash))
887     Fputhash (directory, hash, Vlocate_file_hash_table);
888   return hash;
889 }
890
891 /* find the hash table for the given directory, recalculating if necessary */
892
893 static Lisp_Object
894 locate_file_find_directory_hash_table (Lisp_Object directory)
895 {
896   Lisp_Object hash = Fgethash (directory, Vlocate_file_hash_table, Qnil);
897   if (NILP (hash))
898     return locate_file_refresh_hashing (directory);
899   else
900     return hash;
901 }
902
903 /* The SUFFIXES argument in any of the locate_file* functions can be
904    nil, a list, or a string (for backward compatibility), with the
905    following semantics:
906
907    a) nil    - no suffix, just search for file name intact
908                (semantically different from "empty suffix list", which
909                would be meaningless.)
910    b) list   - list of suffixes to append to file name.  Each of these
911                must be a string.
912    c) string - colon-separated suffixes to append to file name (backward
913                compatibility).
914
915    All of this got hairy, so I decided to use a mapper.  Calling a
916    function for each suffix shouldn't slow things down, since
917    locate_file is rarely called with enough suffixes for funcalls to
918    make any difference.  */
919
920 /* Map FUN over SUFFIXES, as described above.  FUN will be called with a
921    char * containing the current file name, and ARG.  Mapping stops when
922    FUN returns non-zero. */
923 static void
924 locate_file_map_suffixes (Lisp_Object filename, Lisp_Object suffixes,
925                           int (*fun) (char *, void *),
926                           void *arg)
927 {
928   /* This function can GC */
929   char *fn;
930   int fn_len, max;
931
932   /* Calculate maximum size of any filename made from
933      this path element/specified file name and any possible suffix.  */
934   if (CONSP (suffixes))
935     {
936       /* We must traverse the list, so why not do it right. */
937       Lisp_Object tail;
938       max = 0;
939       LIST_LOOP (tail, suffixes)
940         {
941           if (XSTRING_LENGTH (XCAR (tail)) > max)
942             max = XSTRING_LENGTH (XCAR (tail));
943         }
944     }
945   else if (NILP (suffixes))
946     max = 0;
947   else
948     /* Just take the easy way out */
949     max = XSTRING_LENGTH (suffixes);
950
951   fn_len = XSTRING_LENGTH (filename);
952   fn = (char *) alloca (max + fn_len + 1);
953   memcpy (fn, (char *) XSTRING_DATA (filename), fn_len);
954
955   /* Loop over suffixes.  */
956   if (!STRINGP (suffixes))
957     {
958       if (NILP (suffixes))
959         {
960           /* Case a) discussed in the comment above. */
961           fn[fn_len] = 0;
962           if ((*fun) (fn, arg))
963             return;
964         }
965       else
966         {
967           /* Case b) */
968           Lisp_Object tail;
969           LIST_LOOP (tail, suffixes)
970             {
971               memcpy (fn + fn_len, XSTRING_DATA (XCAR (tail)),
972                       XSTRING_LENGTH (XCAR (tail)));
973               fn[fn_len + XSTRING_LENGTH (XCAR (tail))] = 0;
974               if ((*fun) (fn, arg))
975                 return;
976             }
977         }
978     }
979   else
980     {
981       /* Case c) */
982       const char *nsuffix = (const char *) XSTRING_DATA (suffixes);
983
984       while (1)
985         {
986           char *esuffix = (char *) strchr (nsuffix, ':');
987           int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix);
988
989           /* Concatenate path element/specified name with the suffix.  */
990           strncpy (fn + fn_len, nsuffix, lsuffix);
991           fn[fn_len + lsuffix] = 0;
992
993           if ((*fun) (fn, arg))
994             return;
995
996           /* Advance to next suffix.  */
997           if (esuffix == 0)
998             break;
999           nsuffix += lsuffix + 1;
1000         }
1001     }
1002 }
1003
1004 struct locate_file_in_directory_mapper_closure {
1005   int fd;
1006   Lisp_Object *storeptr;
1007   int mode;
1008 };
1009
1010 static int
1011 locate_file_in_directory_mapper (char *fn, void *arg)
1012 {
1013   struct locate_file_in_directory_mapper_closure *closure =
1014     (struct locate_file_in_directory_mapper_closure *)arg;
1015   struct stat st;
1016
1017   /* Ignore file if it's a directory.  */
1018   if (xemacs_stat (fn, &st) >= 0
1019       && (st.st_mode & S_IFMT) != S_IFDIR)
1020     {
1021       /* Check that we can access or open it.  */
1022       if (closure->mode >= 0)
1023         closure->fd = access (fn, closure->mode);
1024       else
1025         closure->fd = open (fn, O_RDONLY | OPEN_BINARY, 0);
1026
1027       if (closure->fd >= 0)
1028         {
1029           /* We succeeded; return this descriptor and filename.  */
1030           if (closure->storeptr)
1031             *closure->storeptr = build_string (fn);
1032
1033 #ifndef WIN32_NATIVE
1034           /* If we actually opened the file, set close-on-exec flag
1035              on the new descriptor so that subprocesses can't whack
1036              at it.  */
1037           if (closure->mode < 0)
1038             (void) fcntl (closure->fd, F_SETFD, FD_CLOEXEC);
1039 #endif
1040
1041           return 1;
1042         }
1043     }
1044   /* Keep mapping. */
1045   return 0;
1046 }
1047
1048
1049 /* look for STR in PATH, optionally adding SUFFIXES.  DIRECTORY need
1050    not have been expanded.  */
1051
1052 static int
1053 locate_file_in_directory (Lisp_Object directory, Lisp_Object str,
1054                           Lisp_Object suffixes, Lisp_Object *storeptr,
1055                           int mode)
1056 {
1057   /* This function can GC */
1058   struct locate_file_in_directory_mapper_closure closure;
1059   Lisp_Object filename = Qnil;
1060   struct gcpro gcpro1, gcpro2, gcpro3;
1061
1062   GCPRO3 (directory, str, filename);
1063
1064   filename = Fexpand_file_name (str, directory);
1065   if (NILP (filename) || NILP (Ffile_name_absolute_p (filename)))
1066     /* If there are non-absolute elts in PATH (eg ".") */
1067     /* Of course, this could conceivably lose if luser sets
1068        default-directory to be something non-absolute ... */
1069     {
1070       if (NILP (filename))
1071         /* NIL means current directory */
1072         filename = current_buffer->directory;
1073       else
1074         filename = Fexpand_file_name (filename,
1075                                       current_buffer->directory);
1076       if (NILP (Ffile_name_absolute_p (filename)))
1077         {
1078           /* Give up on this directory! */
1079           UNGCPRO;
1080           return -1;
1081         }
1082     }
1083
1084   closure.fd = -1;
1085   closure.storeptr = storeptr;
1086   closure.mode = mode;
1087
1088   locate_file_map_suffixes (filename, suffixes, locate_file_in_directory_mapper,
1089                             &closure);
1090
1091   UNGCPRO;
1092   return closure.fd;
1093 }
1094
1095 /* do the same as locate_file() but don't use any hash tables. */
1096
1097 static int
1098 locate_file_without_hash (Lisp_Object path, Lisp_Object str,
1099                           Lisp_Object suffixes, Lisp_Object *storeptr,
1100                           int mode)
1101 {
1102   /* This function can GC */
1103   int absolute = !NILP (Ffile_name_absolute_p (str));
1104
1105   EXTERNAL_LIST_LOOP (path, path)
1106     {
1107       int val = locate_file_in_directory (XCAR (path), str, suffixes, storeptr,
1108                                           mode);
1109       if (val >= 0)
1110         return val;
1111       if (absolute)
1112         break;
1113     }
1114   return -1;
1115 }
1116
1117 static int
1118 locate_file_construct_suffixed_files_mapper (char *fn, void *arg)
1119 {
1120   Lisp_Object *tail = (Lisp_Object *)arg;
1121   *tail = Fcons (build_string (fn), *tail);
1122   return 0;
1123 }
1124
1125 /* Construct a list of all files to search for.
1126    It makes sense to have this despite locate_file_map_suffixes()
1127    because we need Lisp strings to access the hash-table, and it would
1128    be inefficient to create them on the fly, again and again for each
1129    path component.  See locate_file(). */
1130
1131 static Lisp_Object
1132 locate_file_construct_suffixed_files (Lisp_Object filename,
1133                                       Lisp_Object suffixes)
1134 {
1135   Lisp_Object tail = Qnil;
1136   struct gcpro gcpro1;
1137   GCPRO1 (tail);
1138
1139   locate_file_map_suffixes (filename, suffixes,
1140                             locate_file_construct_suffixed_files_mapper,
1141                             &tail);
1142
1143   UNGCPRO;
1144   return Fnreverse (tail);
1145 }
1146
1147 DEFUN ("locate-file-clear-hashing", Flocate_file_clear_hashing, 1, 1, 0, /*
1148 Clear the hash records for the specified list of directories.
1149 `locate-file' uses a hashing scheme to speed lookup, and will correctly
1150 track the following environmental changes:
1151
1152 -- changes of any sort to the list of directories to be searched.
1153 -- addition and deletion of non-shadowing files (see below) from the
1154    directories in the list.
1155 -- byte-compilation of a .el file into a .elc file.
1156
1157 `locate-file' will primarily get confused if you add a file that shadows
1158 \(i.e. has the same name as) another file further down in the directory list.
1159 In this case, you must call `locate-file-clear-hashing'.
1160
1161 If PATH is t, it means to fully clear all the accumulated hashes.  This
1162 can be used if the internal tables grow too large, or when dumping.
1163 */
1164        (path))
1165 {
1166   if (EQ (path, Qt))
1167     Fclrhash (Vlocate_file_hash_table);
1168   else
1169     {
1170       Lisp_Object pathtail;
1171       EXTERNAL_LIST_LOOP (pathtail, path)
1172         {
1173           Lisp_Object pathel = Fexpand_file_name (XCAR (pathtail), Qnil);
1174           Fremhash (pathel, Vlocate_file_hash_table);
1175         }
1176     }
1177   return Qnil;
1178 }
1179
1180 /* Search for a file whose name is STR, looking in directories
1181    in the Lisp list PATH, and trying suffixes from SUFFIXES.
1182    SUFFIXES is a list of possible suffixes, or (for backward
1183    compatibility) a string containing possible suffixes separated by
1184    colons.
1185    On success, returns a file descriptor.  On failure, returns -1.
1186
1187    MODE nonnegative means don't open the files,
1188    just look for one for which access(file,MODE) succeeds.  In this case,
1189    returns 1 on success.
1190
1191    If STOREPTR is nonzero, it points to a slot where the name of
1192    the file actually found should be stored as a Lisp string.
1193    Nil is stored there on failure.
1194
1195    Called openp() in FSFmacs. */
1196
1197 int
1198 locate_file (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
1199              Lisp_Object *storeptr, int mode)
1200 {
1201   /* This function can GC */
1202   Lisp_Object suffixtab = Qnil;
1203   Lisp_Object pathtail, pathel_expanded;
1204   int val;
1205   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1206
1207   if (storeptr)
1208     *storeptr = Qnil;
1209
1210   /* Is it really necessary to gcpro path and str?  It shouldn't be
1211      unless some caller has fucked up.  There are known instances that
1212      call us with build_string("foo:bar") as SUFFIXES, though. */
1213   GCPRO4 (path, str, suffixes, suffixtab);
1214
1215   /* if this filename has directory components, it's too complicated
1216      to try and use the hash tables. */
1217   if (!NILP (Ffile_name_directory (str)))
1218     {
1219       val = locate_file_without_hash (path, str, suffixes, storeptr, mode);
1220       UNGCPRO;
1221       return val;
1222     }
1223
1224   suffixtab = locate_file_construct_suffixed_files (str, suffixes);
1225
1226   EXTERNAL_LIST_LOOP (pathtail, path)
1227     {
1228       Lisp_Object pathel = XCAR (pathtail);
1229       Lisp_Object hash_table;
1230       Lisp_Object tail;
1231       int found = 0;
1232
1233       /* If this path element is relative, we have to look by hand. */
1234       if (NILP (pathel) || NILP (Ffile_name_absolute_p (pathel)))
1235         {
1236           val = locate_file_in_directory (pathel, str, suffixes, storeptr,
1237                                           mode);
1238           if (val >= 0)
1239             {
1240               UNGCPRO;
1241               return val;
1242             }
1243           continue;
1244         }
1245
1246       pathel_expanded = Fexpand_file_name (pathel, Qnil);
1247       hash_table = locate_file_find_directory_hash_table (pathel_expanded);
1248
1249       if (!NILP (hash_table))
1250         {
1251           /* Loop over suffixes.  */
1252           LIST_LOOP (tail, suffixtab)
1253             if (!NILP (Fgethash (XCAR (tail), hash_table, Qnil)))
1254               {
1255                 found = 1;
1256                 break;
1257               }
1258         }
1259
1260       if (found)
1261         {
1262           /* This is a likely candidate.  Look by hand in this directory
1263              so we don't get thrown off if someone byte-compiles a file. */
1264           val = locate_file_in_directory (pathel, str, suffixes, storeptr,
1265                                           mode);
1266           if (val >= 0)
1267             {
1268               UNGCPRO;
1269               return val;
1270             }
1271
1272           /* Hmm ...  the file isn't actually there. (Or possibly it's
1273              a directory ...)  So refresh our hashing. */
1274           locate_file_refresh_hashing (pathel_expanded);
1275         }
1276     }
1277
1278   /* File is probably not there, but check the hard way just in case. */
1279   val = locate_file_without_hash (path, str, suffixes, storeptr, mode);
1280   if (val >= 0)
1281     {
1282       /* Sneaky user added a file without telling us. */
1283       Flocate_file_clear_hashing (path);
1284     }
1285
1286   UNGCPRO;
1287   return val;
1288 }
1289
1290 \f
1291 #ifdef LOADHIST
1292
1293 /* Merge the list we've accumulated of globals from the current input source
1294    into the load_history variable.  The details depend on whether
1295    the source has an associated file name or not. */
1296
1297 static void
1298 build_load_history (int loading, Lisp_Object source)
1299 {
1300   REGISTER Lisp_Object tail, prev, newelt;
1301   REGISTER Lisp_Object tem, tem2;
1302   int foundit;
1303
1304 #if !defined(LOADHIST_DUMPED)
1305   /* Don't bother recording anything for preloaded files.  */
1306   if (purify_flag)
1307     return;
1308 #endif
1309
1310   tail = Vload_history;
1311   prev = Qnil;
1312   foundit = 0;
1313   while (!NILP (tail))
1314     {
1315       tem = Fcar (tail);
1316
1317       /* Find the feature's previous assoc list... */
1318       if (internal_equal (source, Fcar (tem), 0))
1319         {
1320           foundit = 1;
1321
1322           /*  If we're loading, remove it. */
1323           if (loading)
1324             {
1325               if (NILP (prev))
1326                 Vload_history = Fcdr (tail);
1327               else
1328                 Fsetcdr (prev, Fcdr (tail));
1329             }
1330
1331           /*  Otherwise, cons on new symbols that are not already members.  */
1332           else
1333             {
1334               tem2 = Vcurrent_load_list;
1335
1336               while (CONSP (tem2))
1337                 {
1338                   newelt = XCAR (tem2);
1339
1340                   if (NILP (Fmemq (newelt, tem)))
1341                     Fsetcar (tail, Fcons (Fcar (tem),
1342                                           Fcons (newelt, Fcdr (tem))));
1343
1344                   tem2 = XCDR (tem2);
1345                   QUIT;
1346                 }
1347             }
1348         }
1349       else
1350         prev = tail;
1351       tail = Fcdr (tail);
1352       QUIT;
1353     }
1354
1355   /* If we're loading, cons the new assoc onto the front of load-history,
1356      the most-recently-loaded position.  Also do this if we didn't find
1357      an existing member for the current source.  */
1358   if (loading || !foundit)
1359     Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
1360                            Vload_history);
1361 }
1362
1363 #else /* !LOADHIST */
1364 #define build_load_history(x,y)
1365 #endif /* !LOADHIST */
1366
1367 \f
1368 #if 0 /* FSFmacs defun hack */
1369 Lisp_Object
1370 unreadpure (void)       /* Used as unwind-protect function in readevalloop */
1371 {
1372   read_pure = 0;
1373   return Qnil;
1374 }
1375 #endif /* 0 */
1376
1377 static void
1378 readevalloop (Lisp_Object readcharfun,
1379               Lisp_Object sourcename,
1380               Lisp_Object (*evalfun) (Lisp_Object),
1381               int printflag)
1382 {
1383   /* This function can GC */
1384   REGISTER Emchar c;
1385   REGISTER Lisp_Object val = Qnil;
1386   int speccount = specpdl_depth ();
1387   struct gcpro gcpro1, gcpro2;
1388   struct buffer *b = 0;
1389
1390   if (BUFFERP (readcharfun))
1391     b = XBUFFER (readcharfun);
1392   else if (MARKERP (readcharfun))
1393     b = XMARKER (readcharfun)->buffer;
1394
1395   /* Don't do this.  It is not necessary, and it needlessly exposes
1396      READCHARFUN (which can be a stream) to Lisp.  --hniksic */
1397   /*specbind (Qstandard_input, readcharfun);*/
1398
1399   specbind (Qcurrent_load_list, Qnil);
1400
1401 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1402   Vcurrent_compiled_function_annotation = Qnil;
1403 #endif
1404   GCPRO2 (val, sourcename);
1405
1406   LOADHIST_ATTACH (sourcename);
1407
1408   while (1)
1409     {
1410       QUIT;
1411
1412       if (b != 0 && !BUFFER_LIVE_P (b))
1413         error ("Reading from killed buffer");
1414
1415       c = readchar (readcharfun);
1416       if (c == ';')
1417         {
1418           /* Skip comment */
1419           while ((c = readchar (readcharfun)) != '\n' && c != -1)
1420             QUIT;
1421           continue;
1422         }
1423       if (c < 0)
1424         break;
1425
1426       /* Ignore whitespace here, so we can detect eof.  */
1427       if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r')
1428         continue;
1429
1430 #if 0 /* FSFmacs defun hack */
1431       if (purify_flag && c == '(')
1432         {
1433           int count1 = specpdl_depth ();
1434           record_unwind_protect (unreadpure, Qnil);
1435           val = read_list (readcharfun, ')', -1, 1);
1436           unbind_to (count1, Qnil);
1437         }
1438       else
1439 #else /* No "defun hack" -- Emacs 19 uses read-time syntax for bytecodes */
1440         {
1441           unreadchar (readcharfun, c);
1442           Vread_objects = Qnil;
1443           if (NILP (Vload_read_function))
1444             val = read0 (readcharfun);
1445           else
1446             val = call1 (Vload_read_function, readcharfun);
1447         }
1448 #endif
1449       val = (*evalfun) (val);
1450       if (printflag)
1451         {
1452           Vvalues = Fcons (val, Vvalues);
1453           if (EQ (Vstandard_output, Qt))
1454             Fprin1 (val, Qnil);
1455           else
1456             Fprint (val, Qnil);
1457         }
1458     }
1459
1460   build_load_history (LSTREAMP (readcharfun) ||
1461                       /* This looks weird, but it's what's in FSFmacs */
1462                       (b ? BUF_NARROWED (b) : BUF_NARROWED (current_buffer)),
1463                       sourcename);
1464   UNGCPRO;
1465
1466   unbind_to (speccount, Qnil);
1467 }
1468
1469 DEFUN ("eval-buffer", Feval_buffer, 0, 2, "bBuffer: ", /*
1470 Execute BUFFER as Lisp code.
1471 Programs can pass two arguments, BUFFER and PRINTFLAG.
1472 BUFFER is the buffer to evaluate (nil means use current buffer).
1473 PRINTFLAG controls printing of output:
1474 nil means discard it; anything else is a stream for printing.
1475
1476 If there is no error, point does not move.  If there is an error,
1477 point remains at the end of the last character read from the buffer.
1478 */
1479        (buffer, printflag))
1480 {
1481   /* This function can GC */
1482   int speccount = specpdl_depth ();
1483   Lisp_Object tem, buf;
1484
1485   if (NILP (buffer))
1486     buf = Fcurrent_buffer ();
1487   else
1488     buf = Fget_buffer (buffer);
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 START and END
1523 giving starting and ending indices in the current buffer
1524 of the text to be executed.
1525 Programs can pass third optional argument STREAM 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        (start, end, stream))
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 (stream))
1543     tem = Qsymbolp;             /* #### #@[]*&$#*[& SI:NULL-STREAM */
1544   else
1545     tem = stream;
1546   specbind (Qstandard_output, tem);
1547
1548   if (NILP (stream))
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 start and checks its type.  */
1553   Fgoto_char (start, cbuf);
1554   Fnarrow_to_region (make_int (BUF_BEGV (current_buffer)), end, cbuf);
1555   readevalloop (cbuf, XBUFFER (cbuf)->filename, Feval,
1556                 !NILP (stream));
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   Lisp_Object val;
2039
2040   while (1)
2041     {
2042       unsigned char bit;
2043       Emchar c = readchar (readcharfun);
2044       if (c == '0')
2045         bit = 0;
2046       else if (c == '1')
2047         bit = 1;
2048       else
2049         {
2050           if (c >= 0)
2051             unreadchar (readcharfun, c);
2052           break;
2053         }
2054       Dynarr_add (dyn, bit);
2055     }
2056
2057   val = make_bit_vector_from_byte_vector (Dynarr_atp (dyn, 0),
2058                                           Dynarr_length (dyn));
2059   Dynarr_free (dyn);
2060
2061   return val;
2062 }
2063
2064 \f
2065
2066 /* structures */
2067
2068 struct structure_type *
2069 define_structure_type (Lisp_Object type,
2070                        int (*validate) (Lisp_Object data,
2071                                         Error_behavior errb),
2072                        Lisp_Object (*instantiate) (Lisp_Object data))
2073 {
2074   struct structure_type st;
2075
2076   st.type = type;
2077   st.keywords = Dynarr_new (structure_keyword_entry);
2078   st.validate = validate;
2079   st.instantiate = instantiate;
2080   Dynarr_add (the_structure_type_dynarr, st);
2081
2082   return Dynarr_atp (the_structure_type_dynarr,
2083                      Dynarr_length (the_structure_type_dynarr) - 1);
2084 }
2085
2086 void
2087 define_structure_type_keyword (struct structure_type *st, Lisp_Object keyword,
2088                                int (*validate) (Lisp_Object keyword,
2089                                                 Lisp_Object value,
2090                                                 Error_behavior errb))
2091 {
2092   struct structure_keyword_entry en;
2093
2094   en.keyword = keyword;
2095   en.validate = validate;
2096   Dynarr_add (st->keywords, en);
2097 }
2098
2099 static struct structure_type *
2100 recognized_structure_type (Lisp_Object type)
2101 {
2102   int i;
2103
2104   for (i = 0; i < Dynarr_length (the_structure_type_dynarr); i++)
2105     {
2106       struct structure_type *st = Dynarr_atp (the_structure_type_dynarr, i);
2107       if (EQ (st->type, type))
2108         return st;
2109     }
2110
2111   return 0;
2112 }
2113
2114 static Lisp_Object
2115 read_structure (Lisp_Object readcharfun)
2116 {
2117   Emchar c = readchar (readcharfun);
2118   Lisp_Object list = Qnil;
2119   Lisp_Object orig_list = Qnil;
2120   Lisp_Object already_seen = Qnil;
2121   int keyword_count;
2122   struct structure_type *st;
2123   struct gcpro gcpro1, gcpro2;
2124
2125   GCPRO2 (orig_list, already_seen);
2126   if (c != '(')
2127     RETURN_UNGCPRO (continuable_read_syntax_error ("#s not followed by paren"));
2128   list = read_list (readcharfun, ')', 0, 0);
2129   orig_list = list;
2130   {
2131     int len = XINT (Flength (list));
2132     if (len == 0)
2133       RETURN_UNGCPRO (continuable_read_syntax_error
2134                       ("structure type not specified"));
2135     if (!(len & 1))
2136       RETURN_UNGCPRO
2137         (continuable_read_syntax_error
2138          ("structures must have alternating keyword/value pairs"));
2139   }
2140
2141   st = recognized_structure_type (XCAR (list));
2142   if (!st)
2143     RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2144                              list2 (build_translated_string
2145                                     ("unrecognized structure type"),
2146                                     XCAR (list))));
2147
2148   list = Fcdr (list);
2149   keyword_count = Dynarr_length (st->keywords);
2150   while (!NILP (list))
2151     {
2152       Lisp_Object keyword, value;
2153       int i;
2154       struct structure_keyword_entry *en = NULL;
2155
2156       keyword = Fcar (list);
2157       list = Fcdr (list);
2158       value = Fcar (list);
2159       list = Fcdr (list);
2160
2161       if (!NILP (memq_no_quit (keyword, already_seen)))
2162         RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2163                                  list2 (build_translated_string
2164                                         ("structure keyword already seen"),
2165                                         keyword)));
2166
2167       for (i = 0; i < keyword_count; i++)
2168         {
2169           en = Dynarr_atp (st->keywords, i);
2170           if (EQ (keyword, en->keyword))
2171             break;
2172         }
2173
2174       if (i == keyword_count)
2175         RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2176                                    list2 (build_translated_string
2177                                           ("unrecognized structure keyword"),
2178                                           keyword)));
2179
2180       if (en->validate && ! (en->validate) (keyword, value, ERROR_ME))
2181         RETURN_UNGCPRO
2182           (Fsignal (Qinvalid_read_syntax,
2183                     list3 (build_translated_string
2184                            ("invalid value for structure keyword"),
2185                            keyword, value)));
2186
2187       already_seen = Fcons (keyword, already_seen);
2188     }
2189
2190   if (st->validate && ! (st->validate) (orig_list, ERROR_ME))
2191     RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2192                              list2 (build_translated_string
2193                                     ("invalid structure initializer"),
2194                                     orig_list)));
2195
2196   RETURN_UNGCPRO ((st->instantiate) (XCDR (orig_list)));
2197 }
2198
2199 \f
2200 static Lisp_Object read_compiled_function (Lisp_Object readcharfun,
2201                                            int terminator);
2202 static Lisp_Object read_vector (Lisp_Object readcharfun, int terminator);
2203
2204 /* Get the next character; filter out whitespace and comments */
2205
2206 static Emchar
2207 reader_nextchar (Lisp_Object readcharfun)
2208 {
2209   /* This function can GC */
2210   Emchar c;
2211
2212  retry:
2213   QUIT;
2214   c = readchar (readcharfun);
2215   if (c < 0)
2216     signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
2217
2218   switch (c)
2219     {
2220     default:
2221       {
2222         /* Ignore whitespace and control characters */
2223         if (c <= 040)
2224           goto retry;
2225         return c;
2226       }
2227
2228     case ';':
2229       {
2230         /* Comment */
2231         while ((c = readchar (readcharfun)) >= 0 && c != '\n')
2232           QUIT;
2233         goto retry;
2234       }
2235     }
2236 }
2237
2238 #if 0
2239 static Lisp_Object
2240 list2_pure (int pure, Lisp_Object a, Lisp_Object b)
2241 {
2242   return pure ? pure_cons (a, pure_cons (b, Qnil)) : list2 (a, b);
2243 }
2244 #endif
2245
2246 /* Read the next Lisp object from the stream READCHARFUN and return it.
2247    If the return value is a cons whose car is Qunbound, then read1()
2248    encountered a misplaced token (e.g. a right bracket, right paren,
2249    or dot followed by a non-number).  To filter this stuff out,
2250    use read0(). */
2251
2252 static Lisp_Object
2253 read1 (Lisp_Object readcharfun)
2254 {
2255   Emchar c;
2256
2257 retry:
2258   c = reader_nextchar (readcharfun);
2259
2260   switch (c)
2261     {
2262     case '(':
2263       {
2264 #ifdef LISP_BACKQUOTES  /* old backquote compatibility in lisp reader */
2265         /* if this is disabled, then other code in eval.c must be enabled */
2266         Emchar ch = reader_nextchar (readcharfun);
2267         switch (ch)
2268           {
2269           case '`':
2270             {
2271               Lisp_Object tem;
2272               int speccount = specpdl_depth ();
2273               ++old_backquote_flag;
2274               record_unwind_protect (backquote_unwind,
2275                                      make_opaque_ptr (&old_backquote_flag));
2276               tem = read0 (readcharfun);
2277               unbind_to (speccount, Qnil);
2278               ch = reader_nextchar (readcharfun);
2279               if (ch != ')')
2280                 {
2281                   unreadchar (readcharfun, ch);
2282                   return Fsignal (Qinvalid_read_syntax,
2283                                   list1 (build_string
2284                                          ("Weird old-backquote syntax")));
2285                 }
2286               return list2 (Qbacktick, tem);
2287             }
2288           case ',':
2289             {
2290               if (old_backquote_flag)
2291                 {
2292                   Lisp_Object tem, comma_type;
2293                   ch = readchar (readcharfun);
2294                   if (ch == '@')
2295                     comma_type = Qcomma_at;
2296                   else
2297                     {
2298                       if (ch >= 0)
2299                         unreadchar (readcharfun, ch);
2300                       comma_type = Qcomma;
2301                     }
2302                   tem = read0 (readcharfun);
2303                   ch = reader_nextchar (readcharfun);
2304                   if (ch != ')')
2305                     {
2306                       unreadchar (readcharfun, ch);
2307                       return Fsignal (Qinvalid_read_syntax,
2308                                       list1 (build_string
2309                                              ("Weird old-backquote syntax")));
2310                     }
2311                   return list2 (comma_type, tem);
2312                 }
2313               else
2314                 {
2315                   unreadchar (readcharfun, ch);
2316 #if 0
2317                   return Fsignal (Qinvalid_read_syntax,
2318                        list1 (build_string ("Comma outside of backquote")));
2319 #else
2320                   /* #### - yuck....but this is reverse compatible. */
2321                   /* mostly this is required by edebug, which does its own
2322                      annotated reading.  We need to have an annotated_read
2323                      function that records (with markers) the buffer
2324                      positions of the elements that make up lists, then that
2325                      can be used in edebug and bytecomp and the check above
2326                      can go back in. --Stig */
2327                   break;
2328 #endif
2329                 }
2330             }
2331           default:
2332             unreadchar (readcharfun, ch);
2333           }                     /* switch(ch) */
2334 #endif /* old backquote crap... */
2335         return read_list (readcharfun, ')', 1, 1);
2336       }
2337     case '[':
2338       return read_vector (readcharfun, ']');
2339
2340     case ')':
2341     case ']':
2342       /* #### - huh? these don't do what they seem... */
2343       return noseeum_cons (Qunbound, make_char (c));
2344     case '.':
2345       {
2346 #ifdef LISP_FLOAT_TYPE
2347         /* If a period is followed by a number, then we should read it
2348            as a floating point number.  Otherwise, it denotes a dotted
2349            pair.
2350          */
2351         c = readchar (readcharfun);
2352         unreadchar (readcharfun, c);
2353
2354         /* Can't use isdigit on Emchars */
2355         if (c < '0' || c > '9')
2356           return noseeum_cons (Qunbound, make_char ('.'));
2357
2358         /* Note that read_atom will loop
2359            at least once, assuring that we will not try to UNREAD
2360            two characters in a row.
2361            (I think this doesn't matter anymore because there should
2362            be no more danger in unreading multiple characters) */
2363         return read_atom (readcharfun, '.', 0);
2364
2365 #else /* ! LISP_FLOAT_TYPE */
2366         return noseeum_cons (Qunbound, make_char ('.'));
2367 #endif /* ! LISP_FLOAT_TYPE */
2368       }
2369
2370     case '#':
2371       {
2372         c = readchar (readcharfun);
2373         switch (c)
2374           {
2375 #if 0 /* FSFmacs silly char-table syntax */
2376           case '^':
2377 #endif
2378 #if 0 /* FSFmacs silly bool-vector syntax */
2379           case '&':
2380 #endif
2381             /* "#["-- byte-code constant syntax */
2382             /* purecons #[...] syntax */
2383           case '[': return read_compiled_function (readcharfun, ']'
2384                                                    /*, purify_flag */ );
2385             /* "#:"-- gensym syntax */
2386           case ':': return read_atom (readcharfun, -1, 1);
2387             /* #'x => (function x) */
2388           case '\'': return list2 (Qfunction, read0 (readcharfun));
2389 #if 0
2390             /* RMS uses this syntax for fat-strings.
2391                If we use it for vectors, then obscure bugs happen.
2392              */
2393             /* "#(" -- Scheme/CL vector syntax */
2394           case '(': return read_vector (readcharfun, ')');
2395 #endif
2396 #if 0 /* FSFmacs */
2397           case '(':
2398             {
2399               Lisp_Object tmp;
2400               struct gcpro gcpro1;
2401
2402               /* Read the string itself.  */
2403               tmp = read1 (readcharfun);
2404               if (!STRINGP (tmp))
2405                 {
2406                   if (CONSP (tmp) && UNBOUNDP (XCAR (tmp)))
2407                     free_cons (XCONS (tmp));
2408                   return Fsignal (Qinvalid_read_syntax,
2409                                    list1 (build_string ("#")));
2410                 }
2411               GCPRO1 (tmp);
2412               /* Read the intervals and their properties.  */
2413               while (1)
2414                 {
2415                   Lisp_Object beg, end, plist;
2416                   Emchar ch;
2417                   int invalid = 0;
2418
2419                   beg = read1 (readcharfun);
2420                   if (CONSP (beg) && UNBOUNDP (XCAR (beg)))
2421                     {
2422                       ch = XCHAR (XCDR (beg));
2423                       free_cons (XCONS (beg));
2424                       if (ch == ')')
2425                         break;
2426                       else
2427                         invalid = 1;
2428                     }
2429                   if (!invalid)
2430                     {
2431                       end = read1 (readcharfun);
2432                       if (CONSP (end) && UNBOUNDP (XCAR (end)))
2433                         {
2434                           free_cons (XCONS (end));
2435                           invalid = 1;
2436                         }
2437                     }
2438                   if (!invalid)
2439                     {
2440                       plist = read1 (readcharfun);
2441                       if (CONSP (plist) && UNBOUNDP (XCAR (plist)))
2442                         {
2443                           free_cons (XCONS (plist));
2444                           invalid = 1;
2445                         }
2446                     }
2447                   if (invalid)
2448                     RETURN_UNGCPRO
2449                       (Fsignal (Qinvalid_read_syntax,
2450                                 list2
2451                                 (build_string ("invalid string property list"),
2452                                  XCDR (plist))));
2453                   Fset_text_properties (beg, end, plist, tmp);
2454                 }
2455               UNGCPRO;
2456               return tmp;
2457             }
2458 #endif /* 0 */
2459           case '@':
2460             {
2461               /* #@NUMBER is used to skip NUMBER following characters.
2462                  That's used in .elc files to skip over doc strings
2463                  and function definitions.  */
2464               int i, nskip = 0;
2465
2466               /* Read a decimal integer.  */
2467               while ((c = readchar (readcharfun)) >= 0
2468                      && c >= '0' && c <= '9')
2469                 nskip = (10 * nskip) + (c - '0');
2470               if (c >= 0)
2471                 unreadchar (readcharfun, c);
2472
2473               /* FSF has code here that maybe caches the skipped
2474                  string.  See above for why this is totally
2475                  losing.  We handle this differently. */
2476
2477               /* Skip that many characters.  */
2478               for (i = 0; i < nskip && c >= 0; i++)
2479                 c = readchar (readcharfun);
2480
2481               goto retry;
2482             }
2483           case '$': return Vload_file_name_internal;
2484             /* bit vectors */
2485           case '*': return read_bit_vector (readcharfun);
2486             /* #o10 => 8 -- octal constant syntax */
2487           case 'o': return read_integer (readcharfun, 8);
2488             /* #xdead => 57005 -- hex constant syntax */
2489           case 'x': return read_integer (readcharfun, 16);
2490             /* #b010 => 2 -- binary constant syntax */
2491           case 'b': return read_integer (readcharfun, 2);
2492             /* #s(foobar key1 val1 key2 val2) -- structure syntax */
2493           case 's': return read_structure (readcharfun);
2494           case '<':
2495             {
2496               unreadchar (readcharfun, c);
2497               return Fsignal (Qinvalid_read_syntax,
2498                     list1 (build_string ("Cannot read unreadable object")));
2499             }
2500 #ifdef FEATUREP_SYNTAX
2501           case '+':
2502           case '-':
2503             {
2504               Lisp_Object fexp, obj, tem;
2505               struct gcpro gcpro1, gcpro2;
2506
2507               fexp = read0(readcharfun);
2508               obj = read0(readcharfun);
2509
2510               /* the call to `featurep' may GC. */
2511               GCPRO2 (fexp, obj);
2512               tem = call1 (Qfeaturep, fexp);
2513               UNGCPRO;
2514
2515               if (c == '+' &&  NILP(tem)) goto retry;
2516               if (c == '-' && !NILP(tem)) goto retry;
2517               return obj;
2518             }
2519 #endif
2520           case '0': case '1': case '2': case '3': case '4':
2521           case '5': case '6': case '7': case '8': case '9':
2522             /* Reader forms that can reuse previously read objects.  */
2523             {
2524               int n = 0;
2525               Lisp_Object found;
2526
2527               /* Using read_integer() here is impossible, because it
2528                  chokes on `='.  Using parse_integer() is too hard.
2529                  So we simply read it in, and ignore overflows, which
2530                  is safe.  */
2531               while (c >= '0' && c <= '9')
2532                 {
2533                   n *= 10;
2534                   n += c - '0';
2535                   c = readchar (readcharfun);
2536                 }
2537               found = assq_no_quit (make_int (n), Vread_objects);
2538               if (c == '=')
2539                 {
2540                   /* #n=object returns object, but associates it with
2541                      n for #n#.  */
2542                   Lisp_Object obj;
2543                   if (CONSP (found))
2544                     return Fsignal (Qinvalid_read_syntax,
2545                                     list2 (build_translated_string
2546                                            ("Multiply defined symbol label"),
2547                                            make_int (n)));
2548                   obj = read0 (readcharfun);
2549                   Vread_objects = Fcons (Fcons (make_int (n), obj),
2550                                          Vread_objects);
2551                   return obj;
2552                 }
2553               else if (c == '#')
2554                 {
2555                   /* #n# returns a previously read object.  */
2556                   if (CONSP (found))
2557                     return XCDR (found);
2558                   else
2559                     return Fsignal (Qinvalid_read_syntax,
2560                                     list2 (build_translated_string
2561                                            ("Undefined symbol label"),
2562                                            make_int (n)));
2563                 }
2564               return Fsignal (Qinvalid_read_syntax,
2565                               list1 (build_string ("#")));
2566             }
2567           default:
2568             {
2569               unreadchar (readcharfun, c);
2570               return Fsignal (Qinvalid_read_syntax,
2571                               list1 (build_string ("#")));
2572             }
2573           }
2574       }
2575
2576       /* Quote */
2577     case '\'': return list2 (Qquote, read0 (readcharfun));
2578
2579 #ifdef LISP_BACKQUOTES
2580     case '`':
2581       {
2582         Lisp_Object tem;
2583         int speccount = specpdl_depth ();
2584         ++new_backquote_flag;
2585         record_unwind_protect (backquote_unwind,
2586                                make_opaque_ptr (&new_backquote_flag));
2587         tem = read0 (readcharfun);
2588         unbind_to (speccount, Qnil);
2589         return list2 (Qbackquote, tem);
2590       }
2591
2592     case ',':
2593       {
2594         if (new_backquote_flag)
2595           {
2596             Lisp_Object comma_type = Qnil;
2597             int ch = readchar (readcharfun);
2598
2599             if (ch == '@')
2600               comma_type = Qcomma_at;
2601             else if (ch == '.')
2602               comma_type = Qcomma_dot;
2603             else
2604               {
2605                 if (ch >= 0)
2606                   unreadchar (readcharfun, ch);
2607                 comma_type = Qcomma;
2608               }
2609             return list2 (comma_type, read0 (readcharfun));
2610           }
2611         else
2612           {
2613             /* YUCK.  99.999% backwards compatibility.  The Right
2614                Thing(tm) is to signal an error here, because it's
2615                really invalid read syntax.  Instead, this permits
2616                commas to begin symbols (unless they're inside
2617                backquotes).  If an error is signalled here in the
2618                future, then commas should be invalid read syntax
2619                outside of backquotes anywhere they're found (i.e.
2620                they must be quoted in symbols) -- Stig */
2621             return read_atom (readcharfun, c, 0);
2622           }
2623       }
2624 #endif
2625
2626     case '?':
2627       {
2628         /* Evil GNU Emacs "character" (ie integer) syntax */
2629         c = readchar (readcharfun);
2630         if (c < 0)
2631           return Fsignal (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
2632
2633         if (c == '\\')
2634           c = read_escape (readcharfun);
2635         return make_char (c);
2636       }
2637
2638     case '\"':
2639       {
2640         /* String */
2641 #ifdef I18N3
2642         /* #### If the input stream is translating, then the string
2643            should be marked as translatable by setting its
2644            `string-translatable' property to t.  .el and .elc files
2645            normally are translating input streams.  See Fgettext()
2646            and print_internal(). */
2647 #endif
2648         int cancel = 0;
2649
2650         Lstream_rewind (XLSTREAM (Vread_buffer_stream));
2651         while ((c = readchar (readcharfun)) >= 0
2652                && c != '\"')
2653           {
2654             if (c == '\\')
2655               c = read_escape (readcharfun);
2656             /* c is -1 if \ newline has just been seen */
2657             if (c == -1)
2658               {
2659                 if (Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) == 0)
2660                   cancel = 1;
2661               }
2662             else
2663               Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
2664             QUIT;
2665           }
2666         if (c < 0)
2667           return Fsignal (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
2668
2669         /* If purifying, and string starts with \ newline,
2670            return zero instead.  This is for doc strings
2671            that we are really going to find in lib-src/DOC.nn.nn  */
2672         if (purify_flag && NILP (Vinternal_doc_file_name) && cancel)
2673           return Qzero;
2674
2675         Lstream_flush (XLSTREAM (Vread_buffer_stream));
2676         return
2677           make_string
2678           (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
2679            Lstream_byte_count (XLSTREAM (Vread_buffer_stream)));
2680       }
2681
2682     default:
2683       {
2684         /* Ignore whitespace and control characters */
2685         if (c <= 040)
2686           goto retry;
2687         return read_atom (readcharfun, c, 0);
2688       }
2689     }
2690 }
2691
2692
2693 \f
2694 #ifdef LISP_FLOAT_TYPE
2695
2696 #define LEAD_INT 1
2697 #define DOT_CHAR 2
2698 #define TRAIL_INT 4
2699 #define E_CHAR 8
2700 #define EXP_INT 16
2701
2702 int
2703 isfloat_string (const char *cp)
2704 {
2705   int state = 0;
2706   const Bufbyte *ucp = (const Bufbyte *) cp;
2707
2708   if (*ucp == '+' || *ucp == '-')
2709     ucp++;
2710
2711   if (*ucp >= '0' && *ucp <= '9')
2712     {
2713       state |= LEAD_INT;
2714       while (*ucp >= '0' && *ucp <= '9')
2715         ucp++;
2716     }
2717   if (*ucp == '.')
2718     {
2719       state |= DOT_CHAR;
2720       ucp++;
2721     }
2722   if (*ucp >= '0' && *ucp <= '9')
2723     {
2724       state |= TRAIL_INT;
2725       while (*ucp >= '0' && *ucp <= '9')
2726         ucp++;
2727     }
2728   if (*ucp == 'e' || *ucp == 'E')
2729     {
2730       state |= E_CHAR;
2731       ucp++;
2732       if ((*ucp == '+') || (*ucp == '-'))
2733         ucp++;
2734     }
2735
2736   if (*ucp >= '0' && *ucp <= '9')
2737     {
2738       state |= EXP_INT;
2739       while (*ucp >= '0' && *ucp <= '9')
2740         ucp++;
2741     }
2742   return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') || (*ucp == '\n')
2743            || (*ucp == '\r') || (*ucp == '\f'))
2744           && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
2745               || state == (DOT_CHAR|TRAIL_INT)
2746               || state == (LEAD_INT|E_CHAR|EXP_INT)
2747               || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
2748               || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
2749 }
2750 #endif /* LISP_FLOAT_TYPE */
2751 \f
2752 static void *
2753 sequence_reader (Lisp_Object readcharfun,
2754                  Emchar terminator,
2755                  void *state,
2756                  void * (*conser) (Lisp_Object readcharfun,
2757                                    void *state, Charcount len))
2758 {
2759   Charcount len;
2760
2761   for (len = 0; ; len++)
2762     {
2763       Emchar ch;
2764
2765       QUIT;
2766       ch = reader_nextchar (readcharfun);
2767
2768       if (ch == terminator)
2769         return state;
2770       else
2771         unreadchar (readcharfun, ch);
2772 #ifdef FEATUREP_SYNTAX
2773       if (ch == ']')
2774         read_syntax_error ("\"]\" in a list");
2775       else if (ch == ')')
2776         read_syntax_error ("\")\" in a vector");
2777 #endif
2778       state = ((conser) (readcharfun, state, len));
2779     }
2780 }
2781
2782
2783 struct read_list_state
2784   {
2785     Lisp_Object head;
2786     Lisp_Object tail;
2787     int length;
2788     int allow_dotted_lists;
2789     Emchar terminator;
2790   };
2791
2792 static void *
2793 read_list_conser (Lisp_Object readcharfun, void *state, Charcount len)
2794 {
2795   struct read_list_state *s = (struct read_list_state *) state;
2796   Lisp_Object elt;
2797
2798   elt = read1 (readcharfun);
2799
2800   if (CONSP (elt) && UNBOUNDP (XCAR (elt)))
2801     {
2802       Lisp_Object tem = elt;
2803       Emchar ch;
2804
2805       elt = XCDR (elt);
2806       free_cons (XCONS (tem));
2807       tem = Qnil;
2808       ch = XCHAR (elt);
2809 #ifdef FEATUREP_SYNTAX
2810       if (ch == s->terminator) /* deal with #+, #- reader macros */
2811         {
2812           unreadchar (readcharfun, s->terminator);
2813           goto done;
2814         }
2815       else if (ch == ']')
2816         read_syntax_error ("']' in a list");
2817       else if (ch == ')')
2818         read_syntax_error ("')' in a vector");
2819       else
2820 #endif
2821       if (ch != '.')
2822         signal_simple_error ("BUG! Internal reader error", elt);
2823       else if (!s->allow_dotted_lists)
2824         read_syntax_error ("\".\" in a vector");
2825       else
2826         {
2827           if (!NILP (s->tail))
2828             XCDR (s->tail) = read0 (readcharfun);
2829           else
2830             s->head = read0 (readcharfun);
2831           elt = read1 (readcharfun);
2832           if (CONSP (elt) && UNBOUNDP (XCAR (elt)))
2833             {
2834               ch = XCHAR (XCDR (elt));
2835               free_cons (XCONS (elt));
2836               if (ch == s->terminator)
2837                 {
2838                   unreadchar (readcharfun, s->terminator);
2839                   goto done;
2840                 }
2841             }
2842           read_syntax_error (". in wrong context");
2843         }
2844     }
2845
2846 #if 0 /* FSFmacs defun hack, or something ... */
2847   if (NILP (tail) && defun_hack && EQ (elt, Qdefun) && !read_pure)
2848     {
2849       record_unwind_protect (unreadpure, Qzero);
2850       read_pure = 1;
2851     }
2852 #endif
2853
2854 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2855   if (s->length == 1 && s->allow_dotted_lists && EQ (XCAR (s->head), Qfset))
2856     {
2857       if (CONSP (elt) && EQ (XCAR (elt), Qquote) && CONSP (XCDR (elt)))
2858         Vcurrent_compiled_function_annotation = XCAR (XCDR (elt));
2859       else
2860         Vcurrent_compiled_function_annotation = elt;
2861     }
2862 #endif
2863
2864   elt = Fcons (elt, Qnil);
2865   if (!NILP (s->tail))
2866     XCDR (s->tail) = elt;
2867   else
2868     s->head = elt;
2869   s->tail = elt;
2870  done:
2871   s->length++;
2872   return s;
2873 }
2874
2875 \f
2876 #if 0 /* FSFmacs defun hack */
2877 /* -1 for allow_dotted_lists means allow_dotted_lists and check
2878    for starting with defun and make structure pure. */
2879 #endif
2880
2881 static Lisp_Object
2882 read_list (Lisp_Object readcharfun,
2883            Emchar terminator,
2884            int allow_dotted_lists,
2885            int check_for_doc_references)
2886 {
2887   struct read_list_state s;
2888   struct gcpro gcpro1, gcpro2;
2889 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2890   Lisp_Object old_compiled_function_annotation =
2891     Vcurrent_compiled_function_annotation;
2892 #endif
2893
2894   s.head = Qnil;
2895   s.tail = Qnil;
2896   s.length = 0;
2897   s.allow_dotted_lists = allow_dotted_lists;
2898   s.terminator = terminator;
2899   GCPRO2 (s.head, s.tail);
2900
2901   sequence_reader (readcharfun, terminator, &s, read_list_conser);
2902 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2903   Vcurrent_compiled_function_annotation = old_compiled_function_annotation;
2904 #endif
2905
2906   if ((purify_flag || load_force_doc_strings) && check_for_doc_references)
2907     {
2908       /* check now for any doc string references and record them
2909          for later. */
2910       Lisp_Object tail;
2911
2912       /* We might be dealing with an imperfect list so don't
2913          use LIST_LOOP */
2914       for (tail = s.head; CONSP (tail); tail = XCDR (tail))
2915         {
2916           Lisp_Object holding_cons = Qnil;
2917
2918           {
2919             Lisp_Object elem = XCAR (tail);
2920             /* elem might be (#$ . INT) ... */
2921             if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal))
2922               holding_cons = tail;
2923             /* or it might be (quote (#$ . INT)) i.e.
2924                (quote . ((#$ . INT) . nil)) in the case of
2925                `autoload' (autoload evaluates its arguments, while
2926                `defvar', `defun', etc. don't). */
2927             if (CONSP (elem) && EQ (XCAR (elem), Qquote)
2928                 && CONSP (XCDR (elem)))
2929               {
2930                 elem = XCAR (XCDR (elem));
2931                 if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal))
2932                   holding_cons = XCDR (XCAR (tail));
2933               }
2934           }
2935
2936           if (CONSP (holding_cons))
2937             {
2938               if (purify_flag)
2939                 {
2940                   if (NILP (Vinternal_doc_file_name))
2941                     /* We have not yet called Snarf-documentation, so
2942                        assume this file is described in the DOC file
2943                        and Snarf-documentation will fill in the right
2944                        value later.  For now, replace the whole list
2945                        with 0.  */
2946                     XCAR (holding_cons) = Qzero;
2947                   else
2948                     /* We have already called Snarf-documentation, so
2949                        make a relative file name for this file, so it
2950                        can be found properly in the installed Lisp
2951                        directory.  We don't use Fexpand_file_name
2952                        because that would make the directory absolute
2953                        now.  */
2954                     XCAR (XCAR (holding_cons)) =
2955                       concat2 (build_string ("../lisp/"),
2956                                Ffile_name_nondirectory
2957                                (Vload_file_name_internal));
2958                 }
2959               else
2960                 /* Not pure.  Just add to Vload_force_doc_string_list,
2961                    and the string will be filled in properly in
2962                    load_force_doc_string_unwind(). */
2963                 Vload_force_doc_string_list =
2964                   /* We pass the cons that holds the (#$ . INT) so we
2965                      can modify it in-place. */
2966                   Fcons (holding_cons, Vload_force_doc_string_list);
2967             }
2968         }
2969     }
2970
2971   UNGCPRO;
2972   return s.head;
2973 }
2974
2975 static Lisp_Object
2976 read_vector (Lisp_Object readcharfun,
2977              Emchar terminator)
2978 {
2979   Lisp_Object tem;
2980   Lisp_Object *p;
2981   int len;
2982   int i;
2983   struct read_list_state s;
2984   struct gcpro gcpro1, gcpro2;
2985
2986   s.head = Qnil;
2987   s.tail = Qnil;
2988   s.length = 0;
2989   s.allow_dotted_lists = 0;
2990   GCPRO2 (s.head, s.tail);
2991
2992   sequence_reader (readcharfun, terminator, &s, read_list_conser);
2993
2994   UNGCPRO;
2995   tem = s.head;
2996   len = XINT (Flength (tem));
2997
2998 #if 0 /* FSFmacs defun hack */
2999   if (read_pure)
3000     s.head = make_pure_vector (len, Qnil);
3001   else
3002 #endif
3003     s.head = make_vector (len, Qnil);
3004
3005   for (i = 0, p = &(XVECTOR_DATA (s.head)[0]);
3006        i < len;
3007        i++, p++)
3008   {
3009     Lisp_Cons *otem = XCONS (tem);
3010     tem = Fcar (tem);
3011     *p = tem;
3012     tem = otem->cdr;
3013     free_cons (otem);
3014   }
3015   return s.head;
3016 }
3017
3018 static Lisp_Object
3019 read_compiled_function (Lisp_Object readcharfun, Emchar terminator)
3020 {
3021   /* Accept compiled functions at read-time so that we don't
3022      have to build them at load-time. */
3023   Lisp_Object stuff;
3024   Lisp_Object make_byte_code_args[COMPILED_DOMAIN + 1];
3025   struct gcpro gcpro1;
3026   int len;
3027   int iii;
3028   int saw_a_doc_ref = 0;
3029
3030   /* Note: we tell read_list not to search for doc references
3031      because we need to handle the "doc reference" for the
3032      instructions and constants differently. */
3033   stuff = read_list (readcharfun, terminator, 0, 0);
3034   len = XINT (Flength (stuff));
3035   if (len < COMPILED_STACK_DEPTH + 1 || len > COMPILED_DOMAIN + 1)
3036     return
3037       continuable_read_syntax_error ("#[...] used with wrong number of elements");
3038
3039   for (iii = 0; CONSP (stuff); iii++)
3040     {
3041       Lisp_Cons *victim = XCONS (stuff);
3042       make_byte_code_args[iii] = Fcar (stuff);
3043       if ((purify_flag || load_force_doc_strings)
3044            && CONSP (make_byte_code_args[iii])
3045           && EQ (XCAR (make_byte_code_args[iii]), Vload_file_name_internal))
3046         {
3047           if (purify_flag && iii == COMPILED_DOC_STRING)
3048             {
3049               /* same as in read_list(). */
3050               if (NILP (Vinternal_doc_file_name))
3051                 make_byte_code_args[iii] = Qzero;
3052               else
3053                 XCAR (make_byte_code_args[iii]) =
3054                   concat2 (build_string ("../lisp/"),
3055                            Ffile_name_nondirectory
3056                            (Vload_file_name_internal));
3057             }
3058           else
3059             saw_a_doc_ref = 1;
3060         }
3061       stuff = Fcdr (stuff);
3062       free_cons (victim);
3063     }
3064   GCPRO1 (make_byte_code_args[0]);
3065   gcpro1.nvars = len;
3066
3067   /* v18 or v19 bytecode file.  Need to Ebolify. */
3068   if (load_byte_code_version < 20 && VECTORP (make_byte_code_args[2]))
3069     ebolify_bytecode_constants (make_byte_code_args[2]);
3070
3071   /* make-byte-code looks at purify_flag, which should have the same
3072    *  value as our "read-pure" argument */
3073   stuff = Fmake_byte_code (len, make_byte_code_args);
3074   XCOMPILED_FUNCTION (stuff)->flags.ebolified = (load_byte_code_version < 20);
3075   if (saw_a_doc_ref)
3076     Vload_force_doc_string_list = Fcons (stuff, Vload_force_doc_string_list);
3077   UNGCPRO;
3078   return stuff;
3079 }
3080
3081
3082 \f
3083 void
3084 init_lread (void)
3085 {
3086   Vvalues = Qnil;
3087
3088   load_in_progress = 0;
3089
3090   Vload_descriptor_list = Qnil;
3091
3092   /* kludge: locate-file does not work for a null load-path, even if
3093      the file name is absolute. */
3094
3095   Vload_path = Fcons (build_string (""), Qnil);
3096
3097   /* This used to get initialized in init_lread because all streams
3098      got closed when dumping occurs.  This is no longer true --
3099      Vread_buffer_stream is a resizing output stream, and there is no
3100      reason to close it at dump-time.
3101
3102      Vread_buffer_stream is set to Qnil in vars_of_lread, and this
3103      will initialize it only once, at dump-time.  */
3104   if (NILP (Vread_buffer_stream))
3105     Vread_buffer_stream = make_resizing_buffer_output_stream ();
3106
3107   Vload_force_doc_string_list = Qnil;
3108 }
3109
3110 void
3111 syms_of_lread (void)
3112 {
3113   DEFSUBR (Fread);
3114   DEFSUBR (Fread_from_string);
3115   DEFSUBR (Fload_internal);
3116   DEFSUBR (Flocate_file);
3117   DEFSUBR (Flocate_file_clear_hashing);
3118   DEFSUBR (Feval_buffer);
3119   DEFSUBR (Feval_region);
3120
3121   defsymbol (&Qstandard_input, "standard-input");
3122   defsymbol (&Qread_char, "read-char");
3123   defsymbol (&Qcurrent_load_list, "current-load-list");
3124   defsymbol (&Qload, "load");
3125   defsymbol (&Qload_file_name, "load-file-name");
3126   defsymbol (&Qfset, "fset");
3127
3128 #ifdef LISP_BACKQUOTES
3129   defsymbol (&Qbackquote, "backquote");
3130   defsymbol (&Qbacktick, "`");
3131   defsymbol (&Qcomma, ",");
3132   defsymbol (&Qcomma_at, ",@");
3133   defsymbol (&Qcomma_dot, ",.");
3134 #endif
3135
3136   defsymbol (&Qexists, "exists");
3137   defsymbol (&Qreadable, "readable");
3138   defsymbol (&Qwritable, "writable");
3139   defsymbol (&Qexecutable, "executable");
3140 }
3141
3142 void
3143 structure_type_create (void)
3144 {
3145   the_structure_type_dynarr = Dynarr_new (structure_type);
3146 }
3147
3148 void
3149 reinit_vars_of_lread (void)
3150 {
3151   Vread_buffer_stream = Qnil;
3152   staticpro_nodump (&Vread_buffer_stream);
3153 }
3154
3155 void
3156 vars_of_lread (void)
3157 {
3158   reinit_vars_of_lread ();
3159
3160   DEFVAR_LISP ("values", &Vvalues /*
3161 List of values of all expressions which were read, evaluated and printed.
3162 Order is reverse chronological.
3163 */ );
3164
3165   DEFVAR_LISP ("standard-input", &Vstandard_input /*
3166 Stream for read to get input from.
3167 See documentation of `read' for possible values.
3168 */ );
3169   Vstandard_input = Qt;
3170
3171   DEFVAR_LISP ("load-path", &Vload_path /*
3172 *List of directories to search for files to load.
3173 Each element is a string (directory name) or nil (try default directory).
3174
3175 Note that the elements of this list *may not* begin with "~", so you must
3176 call `expand-file-name' on them before adding them to this list.
3177
3178 Initialized based on EMACSLOADPATH environment variable, if any,
3179 otherwise to default specified in by file `paths.h' when XEmacs was built.
3180 If there were no paths specified in `paths.h', then XEmacs chooses a default
3181 value for this variable by looking around in the file-system near the
3182 directory in which the XEmacs executable resides.
3183 */ );
3184   Vload_path = Qnil;
3185
3186 /*  xxxDEFVAR_LISP ("dump-load-path", &Vdump_load_path,
3187     "*Location of lisp files to be used when dumping ONLY."); */
3188
3189   DEFVAR_BOOL ("load-in-progress", &load_in_progress /*
3190 Non-nil iff inside of `load'.
3191 */ );
3192
3193   DEFVAR_LISP ("after-load-alist", &Vafter_load_alist /*
3194 An alist of expressions to be evalled when particular files are loaded.
3195 Each element looks like (FILENAME FORMS...).
3196 When `load' is run and the file-name argument is FILENAME,
3197 the FORMS in the corresponding element are executed at the end of loading.
3198
3199 FILENAME must match exactly!  Normally FILENAME is the name of a library,
3200 with no directory specified, since that is how `load' is normally called.
3201 An error in FORMS does not undo the load,
3202 but does prevent execution of the rest of the FORMS.
3203 */ );
3204   Vafter_load_alist = Qnil;
3205
3206   DEFVAR_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer /*
3207 *Whether `load' should check whether the source is newer than the binary.
3208 If this variable is true, then when a `.elc' file is being loaded and the
3209 corresponding `.el' is newer, a warning message will be printed.
3210 */ );
3211   load_warn_when_source_newer = 0;
3212
3213   DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only /*
3214 *Whether `load' should warn when loading a `.el' file instead of an `.elc'.
3215 If this variable is true, then when `load' is called with a filename without
3216 an extension, and the `.elc' version doesn't exist but the `.el' version does,
3217 then a message will be printed.  If an explicit extension is passed to `load',
3218 no warning will be printed.
3219 */ );
3220   load_warn_when_source_only = 0;
3221
3222   DEFVAR_BOOL ("load-ignore-elc-files", &load_ignore_elc_files /*
3223 *Whether `load' should ignore `.elc' files when a suffix is not given.
3224 This is normally used only to bootstrap the `.elc' files when building XEmacs.
3225 */ );
3226   load_ignore_elc_files = 0;
3227
3228 #ifdef LOADHIST
3229   DEFVAR_LISP ("load-history", &Vload_history /*
3230 Alist mapping source file names to symbols and features.
3231 Each alist element is a list that starts with a file name,
3232 except for one element (optional) that starts with nil and describes
3233 definitions evaluated from buffers not visiting files.
3234 The remaining elements of each list are symbols defined as functions
3235 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.
3236 */ );
3237   Vload_history = Qnil;
3238
3239   DEFVAR_LISP ("current-load-list", &Vcurrent_load_list /*
3240 Used for internal purposes by `load'.
3241 */ );
3242   Vcurrent_load_list = Qnil;
3243 #endif
3244
3245   DEFVAR_LISP ("load-file-name", &Vload_file_name /*
3246 Full name of file being loaded by `load'.
3247 */ );
3248   Vload_file_name = Qnil;
3249
3250   DEFVAR_LISP ("load-read-function", &Vload_read_function /*
3251 Function used by `load' and `eval-region' for reading expressions.
3252 The default is nil, which means use the function `read'.
3253 */ );
3254   Vload_read_function = Qnil;
3255
3256   DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings /*
3257 Non-nil means `load' should force-load all dynamic doc strings.
3258 This is useful when the file being loaded is a temporary copy.
3259 */ );
3260   load_force_doc_strings = 0;
3261
3262   /* See read_escape().  */
3263 #if 0
3264   /* Used to be named `puke-on-fsf-keys' */
3265   DEFVAR_BOOL ("fail-on-bucky-bit-character-escapes",
3266                &fail_on_bucky_bit_character_escapes /*
3267 Whether `read' should signal an error when it encounters unsupported
3268 character escape syntaxes or just read them incorrectly.
3269 */ );
3270   fail_on_bucky_bit_character_escapes = 0;
3271 #endif
3272
3273   /* This must be initialized in init_lread otherwise it may start out
3274      with values saved when the image is dumped. */
3275   staticpro (&Vload_descriptor_list);
3276
3277   /* Initialized in init_lread. */
3278   staticpro (&Vload_force_doc_string_list);
3279
3280   Vload_file_name_internal = Qnil;
3281   staticpro (&Vload_file_name_internal);
3282
3283   Vload_file_name_internal_the_purecopy = Qnil;
3284   staticpro (&Vload_file_name_internal_the_purecopy);
3285
3286 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3287   Vcurrent_compiled_function_annotation = Qnil;
3288   staticpro (&Vcurrent_compiled_function_annotation);
3289 #endif
3290
3291   /* So that early-early stuff will work */
3292   Ffset (Qload, intern ("load-internal"));
3293
3294 #ifdef FEATUREP_SYNTAX
3295   defsymbol (&Qfeaturep, "featurep");
3296   Fprovide(intern("xemacs"));
3297 #ifdef INFODOCK
3298   Fprovide(intern("infodock"));
3299 #endif /* INFODOCK */
3300 #endif /* FEATUREP_SYNTAX */
3301
3302 #ifdef LISP_BACKQUOTES
3303   old_backquote_flag = new_backquote_flag = 0;
3304 #endif
3305
3306 #ifdef I18N3
3307   Vfile_domain = Qnil;
3308 #endif
3309
3310   Vread_objects = Qnil;
3311   staticpro (&Vread_objects);
3312
3313   Vlocate_file_hash_table = make_lisp_hash_table (200,
3314                                                   HASH_TABLE_NON_WEAK,
3315                                                   HASH_TABLE_EQUAL);
3316   staticpro (&Vlocate_file_hash_table);
3317 #ifdef DEBUG_XEMACS
3318   symbol_value (XSYMBOL (intern ("Vlocate-file-hash-table")))
3319     = Vlocate_file_hash_table;
3320 #endif
3321 }