(char-db-feature-domains): Delete `jis/alt' because it has been
[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 : (int) 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 a nonnegative value on success.  On failure, returns -1.
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 Lisp_Object
1636 read_from_c_string (const unsigned char* str, size_t size)
1637 {
1638   Lisp_Object tem;
1639   Lisp_Object lispstream = Qnil;
1640   struct gcpro gcpro1;
1641
1642 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1643   Vcurrent_compiled_function_annotation = Qnil;
1644 #endif
1645   GCPRO1 (lispstream);
1646   lispstream = make_fixed_buffer_input_stream (str, size);
1647
1648   Vread_objects = Qnil;
1649
1650   tem = read0 (lispstream);
1651   Lstream_delete (XLSTREAM (lispstream));
1652   UNGCPRO;
1653   return tem;
1654 }
1655 \f
1656 #ifdef LISP_BACKQUOTES
1657
1658 static Lisp_Object
1659 backquote_unwind (Lisp_Object ptr)
1660 {  /* used as unwind-protect function in read0() */
1661   int *counter = (int *) get_opaque_ptr (ptr);
1662   if (--*counter < 0)
1663     *counter = 0;
1664   free_opaque_ptr (ptr);
1665   return Qnil;
1666 }
1667
1668 #endif
1669
1670 /* Use this for recursive reads, in contexts where internal tokens
1671    are not allowed.  See also read1(). */
1672 static Lisp_Object
1673 read0 (Lisp_Object readcharfun)
1674 {
1675   Lisp_Object val = read1 (readcharfun);
1676
1677   if (CONSP (val) && UNBOUNDP (XCAR (val)))
1678     {
1679       Emchar c = XCHAR (XCDR (val));
1680       free_cons (XCONS (val));
1681       return Fsignal (Qinvalid_read_syntax,
1682                       list1 (Fchar_to_string (make_char (c))));
1683     }
1684
1685   return val;
1686 }
1687 \f
1688 static Emchar
1689 read_escape (Lisp_Object readcharfun)
1690 {
1691   /* This function can GC */
1692   Emchar c = readchar (readcharfun);
1693
1694   if (c < 0)
1695     signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
1696
1697   switch (c)
1698     {
1699     case 'a': return '\007';
1700     case 'b': return '\b';
1701     case 'd': return 0177;
1702     case 'e': return 033;
1703     case 'f': return '\f';
1704     case 'n': return '\n';
1705     case 'r': return '\r';
1706     case 't': return '\t';
1707     case 'v': return '\v';
1708     case '\n': return -1;
1709
1710     case 'M':
1711       c = readchar (readcharfun);
1712       if (c < 0)
1713         signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
1714       if (c != '-')
1715         error ("Invalid escape character syntax");
1716       c = readchar (readcharfun);
1717       if (c < 0)
1718         signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
1719       if (c == '\\')
1720         c = read_escape (readcharfun);
1721       return c | 0200;
1722
1723       /* Originally, FSF_KEYS provided a degree of FSF Emacs
1724          compatibility by defining character "modifiers" alt, super,
1725          hyper and shift to infest the characters (i.e. integers).
1726
1727          However, this doesn't cut it for XEmacs 20, which
1728          distinguishes characters from integers.  Without Mule, ?\H-a
1729          simply returns ?a because every character is clipped into
1730          0-255.  Under Mule it is much worse -- ?\H-a with FSF_KEYS
1731          produces an illegal character, and moves us to crash-land.
1732
1733          For these reasons, FSF_KEYS hack is useless and without hope
1734          of ever working under XEmacs 20.  */
1735 #undef FSF_KEYS
1736
1737 #ifdef FSF_KEYS
1738 #define alt_modifier   (0x040000)
1739 #define super_modifier (0x080000)
1740 #define hyper_modifier (0x100000)
1741 #define shift_modifier (0x200000)
1742 /* fsf uses a different modifiers for meta and control.  Possibly
1743    byte_compiled code will still work fsfmacs, though... --Stig
1744
1745    #define ctl_modifier   (0x400000)
1746    #define meta_modifier  (0x800000)
1747 */
1748 #define FSF_LOSSAGE(mask)                                                       \
1749       if (fail_on_bucky_bit_character_escapes ||                                \
1750           ((c = readchar (readcharfun)) != '-'))                                \
1751         error ("Invalid escape character syntax");                              \
1752       c = readchar (readcharfun);                                               \
1753       if (c < 0)                                                                \
1754         signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));   \
1755       if (c == '\\')                                                            \
1756         c = read_escape (readcharfun);                                          \
1757       return c | mask
1758
1759     case 'S': FSF_LOSSAGE (shift_modifier);
1760     case 'H': FSF_LOSSAGE (hyper_modifier);
1761     case 'A': FSF_LOSSAGE (alt_modifier);
1762     case 's': FSF_LOSSAGE (super_modifier);
1763 #undef alt_modifier
1764 #undef super_modifier
1765 #undef hyper_modifier
1766 #undef shift_modifier
1767 #undef FSF_LOSSAGE
1768
1769 #endif /* FSF_KEYS */
1770
1771     case 'C':
1772       c = readchar (readcharfun);
1773       if (c < 0)
1774         signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
1775       if (c != '-')
1776         error ("Invalid escape character syntax");
1777     case '^':
1778       c = readchar (readcharfun);
1779       if (c < 0)
1780         signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
1781       if (c == '\\')
1782         c = read_escape (readcharfun);
1783       /* FSFmacs junk for non-ASCII controls.
1784          Not used here. */
1785       if (c == '?')
1786         return 0177;
1787       else
1788         return c & (0200 | 037);
1789
1790     case '0':
1791     case '1':
1792     case '2':
1793     case '3':
1794     case '4':
1795     case '5':
1796     case '6':
1797     case '7':
1798       /* An octal escape, as in ANSI C.  */
1799       {
1800         REGISTER Emchar i = c - '0';
1801         REGISTER int count = 0;
1802         while (++count < 3)
1803           {
1804             if ((c = readchar (readcharfun)) >= '0' && c <= '7')
1805               i = (i << 3) + (c - '0');
1806             else
1807               {
1808                 unreadchar (readcharfun, c);
1809                 break;
1810               }
1811           }
1812         return i;
1813       }
1814
1815     case 'x':
1816       /* A hex escape, as in ANSI C, except that we only allow latin-1
1817          characters to be read this way.  What is "\x4e03" supposed to
1818          mean, anyways, if the internal representation is hidden?
1819          This is also consistent with the treatment of octal escapes. */
1820       {
1821         REGISTER Emchar i = 0;
1822         REGISTER int count = 0;
1823         while (++count <= 2)
1824           {
1825             c = readchar (readcharfun);
1826             /* Remember, can't use isdigit(), isalpha() etc. on Emchars */
1827             if      (c >= '0' && c <= '9')  i = (i << 4) + (c - '0');
1828             else if (c >= 'a' && c <= 'f')  i = (i << 4) + (c - 'a') + 10;
1829             else if (c >= 'A' && c <= 'F')  i = (i << 4) + (c - 'A') + 10;
1830             else
1831               {
1832                 unreadchar (readcharfun, c);
1833                 break;
1834               }
1835           }
1836         return i;
1837       }
1838     case 'u':
1839       {
1840         REGISTER Emchar i = 0;
1841         REGISTER int count = 0;
1842         while (++count <= 6)
1843           {
1844             c = readchar (readcharfun);
1845             /* Remember, can't use isdigit(), isalpha() etc. on Emchars */
1846             if      (c >= '0' && c <= '9')  i = (i << 4) + (c - '0');
1847             else if (c >= 'a' && c <= 'f')  i = (i << 4) + (c - 'a') + 10;
1848             else if (c >= 'A' && c <= 'F')  i = (i << 4) + (c - 'A') + 10;
1849             else
1850               {
1851                 unreadchar (readcharfun, c);
1852                 break;
1853               }
1854           }
1855         return i;
1856       }
1857
1858 #ifdef MULE
1859       /* #### need some way of reading an extended character with
1860          an escape sequence. */
1861 #endif
1862
1863     default:
1864         return c;
1865     }
1866 }
1867
1868
1869 \f
1870 /* read symbol-constituent stuff into `Vread_buffer_stream'. */
1871 static Bytecount
1872 read_atom_0 (Lisp_Object readcharfun, Emchar firstchar, int *saw_a_backslash)
1873 {
1874   /* This function can GC */
1875   Emchar c = ((firstchar) >= 0 ? firstchar : readchar (readcharfun));
1876   Lstream_rewind (XLSTREAM (Vread_buffer_stream));
1877
1878   *saw_a_backslash = 0;
1879
1880   while (c > 040        /* #### - comma should be here as should backquote */
1881          && !(c == '\"' || c == '\'' || c == ';'
1882               || c == '(' || c == ')'
1883 #ifndef LISP_FLOAT_TYPE
1884               /* If we have floating-point support, then we need
1885                  to allow <digits><dot><digits>.  */
1886               || c =='.'
1887 #endif /* not LISP_FLOAT_TYPE */
1888               || c == '[' || c == ']' || c == '#'
1889               ))
1890     {
1891       if (c == '\\')
1892         {
1893           c = readchar (readcharfun);
1894           if (c < 0)
1895             signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
1896           *saw_a_backslash = 1;
1897         }
1898       Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
1899       QUIT;
1900       c = readchar (readcharfun);
1901     }
1902
1903   if (c >= 0)
1904     unreadchar (readcharfun, c);
1905   /* blasted terminating 0 */
1906   Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), 0);
1907   Lstream_flush (XLSTREAM (Vread_buffer_stream));
1908
1909   return Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) - 1;
1910 }
1911
1912 static Lisp_Object parse_integer (const Bufbyte *buf, Bytecount len, int base);
1913
1914 static Lisp_Object
1915 read_atom (Lisp_Object readcharfun,
1916            Emchar firstchar,
1917            int uninterned_symbol)
1918 {
1919   /* This function can GC */
1920   int saw_a_backslash;
1921   Bytecount len = read_atom_0 (readcharfun, firstchar, &saw_a_backslash);
1922   char *read_ptr = (char *)
1923     resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream));
1924
1925   /* Is it an integer? */
1926   if (! (saw_a_backslash || uninterned_symbol))
1927     {
1928       /* If a token had any backslashes in it, it is disqualified from
1929          being an integer or a float.  This means that 123\456 is a
1930          symbol, as is \123 (which is the way (intern "123") prints).
1931          Also, if token was preceded by #:, it's always a symbol.
1932        */
1933       char *p = read_ptr + len;
1934       char *p1 = read_ptr;
1935
1936       if (*p1 == '+' || *p1 == '-') p1++;
1937       if (p1 != p)
1938         {
1939           int c;
1940
1941           while (p1 != p && (c = *p1) >= '0' && c <= '9')
1942             p1++;
1943 #ifdef LISP_FLOAT_TYPE
1944           /* Integers can have trailing decimal points.  */
1945           if (p1 > read_ptr && p1 < p && *p1 == '.')
1946             p1++;
1947 #endif
1948           if (p1 == p)
1949             {
1950               /* It is an integer. */
1951 #ifdef LISP_FLOAT_TYPE
1952               if (p1[-1] == '.')
1953                 p1[-1] = '\0';
1954 #endif
1955 #if 0
1956               {
1957                 int number = 0;
1958                 if (sizeof (int) == sizeof (EMACS_INT))
1959                   number = atoi (read_buffer);
1960                 else if (sizeof (long) == sizeof (EMACS_INT))
1961                   number = atol (read_buffer);
1962                 else
1963                   ABORT ();
1964                 return make_int (number);
1965               }
1966 #else
1967               return parse_integer ((Bufbyte *) read_ptr, len, 10);
1968 #endif
1969             }
1970         }
1971 #ifdef LISP_FLOAT_TYPE
1972       if (isfloat_string (read_ptr))
1973         return make_float (atof (read_ptr));
1974 #endif
1975     }
1976
1977   {
1978     Lisp_Object sym;
1979     if (uninterned_symbol)
1980       sym = Fmake_symbol ( make_string ((Bufbyte *) read_ptr, len));
1981     else
1982       {
1983         Lisp_Object name = make_string ((Bufbyte *) read_ptr, len);
1984         sym = Fintern (name, Qnil);
1985       }
1986     return sym;
1987   }
1988 }
1989
1990
1991 static Lisp_Object
1992 parse_integer (const Bufbyte *buf, Bytecount len, int base)
1993 {
1994   const Bufbyte *lim = buf + len;
1995   const Bufbyte *p = buf;
1996   EMACS_UINT num = 0;
1997   int negativland = 0;
1998
1999   if (*p == '-')
2000     {
2001       negativland = 1;
2002       p++;
2003     }
2004   else if (*p == '+')
2005     {
2006       p++;
2007     }
2008
2009   if (p == lim)
2010     goto loser;
2011
2012   for (; (p < lim) && (*p != '\0'); p++)
2013     {
2014       int c = *p;
2015       EMACS_UINT onum;
2016
2017       if (isdigit (c))
2018         c = c - '0';
2019       else if (isupper (c))
2020         c = c - 'A' + 10;
2021       else if (islower (c))
2022         c = c - 'a' + 10;
2023       else
2024         goto loser;
2025
2026       if (c < 0 || c >= base)
2027         goto loser;
2028
2029       onum = num;
2030       num = num * base + c;
2031       if (num < onum)
2032         goto overflow;
2033     }
2034
2035   {
2036     EMACS_INT int_result = negativland ? - (EMACS_INT) num : (EMACS_INT) num;
2037     Lisp_Object result = make_int (int_result);
2038     if (num && ((XINT (result) < 0) != negativland))
2039       goto overflow;
2040     if (XINT (result) != int_result)
2041       goto overflow;
2042     return result;
2043   }
2044  overflow:
2045   return Fsignal (Qinvalid_read_syntax,
2046                   list3 (build_translated_string
2047                          ("Integer constant overflow in reader"),
2048                          make_string (buf, len),
2049                          make_int (base)));
2050  loser:
2051   return Fsignal (Qinvalid_read_syntax,
2052                   list3 (build_translated_string
2053                          ("Invalid integer constant in reader"),
2054                          make_string (buf, len),
2055                          make_int (base)));
2056 }
2057
2058
2059 static Lisp_Object
2060 read_integer (Lisp_Object readcharfun, int base)
2061 {
2062   /* This function can GC */
2063   int saw_a_backslash;
2064   Bytecount len = read_atom_0 (readcharfun, -1, &saw_a_backslash);
2065   return (parse_integer
2066           (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
2067            ((saw_a_backslash)
2068             ? 0 /* make parse_integer signal error */
2069             : len),
2070            base));
2071 }
2072
2073 static Lisp_Object
2074 read_bit_vector (Lisp_Object readcharfun)
2075 {
2076   unsigned_char_dynarr *dyn = Dynarr_new (unsigned_char);
2077   Lisp_Object val;
2078
2079   while (1)
2080     {
2081       unsigned char bit;
2082       Emchar c = readchar (readcharfun);
2083       if (c == '0')
2084         bit = 0;
2085       else if (c == '1')
2086         bit = 1;
2087       else
2088         {
2089           if (c >= 0)
2090             unreadchar (readcharfun, c);
2091           break;
2092         }
2093       Dynarr_add (dyn, bit);
2094     }
2095
2096   val = make_bit_vector_from_byte_vector (Dynarr_atp (dyn, 0),
2097                                           Dynarr_length (dyn));
2098   Dynarr_free (dyn);
2099
2100   return val;
2101 }
2102
2103 \f
2104
2105 /* structures */
2106
2107 struct structure_type *
2108 define_structure_type (Lisp_Object type,
2109                        int (*validate) (Lisp_Object data,
2110                                         Error_behavior errb),
2111                        Lisp_Object (*instantiate) (Lisp_Object data))
2112 {
2113   struct structure_type st;
2114
2115   st.type = type;
2116   st.keywords = Dynarr_new (structure_keyword_entry);
2117   st.validate = validate;
2118   st.instantiate = instantiate;
2119   Dynarr_add (the_structure_type_dynarr, st);
2120
2121   return Dynarr_atp (the_structure_type_dynarr,
2122                      Dynarr_length (the_structure_type_dynarr) - 1);
2123 }
2124
2125 void
2126 define_structure_type_keyword (struct structure_type *st, Lisp_Object keyword,
2127                                int (*validate) (Lisp_Object keyword,
2128                                                 Lisp_Object value,
2129                                                 Error_behavior errb))
2130 {
2131   struct structure_keyword_entry en;
2132
2133   en.keyword = keyword;
2134   en.validate = validate;
2135   Dynarr_add (st->keywords, en);
2136 }
2137
2138 static struct structure_type *
2139 recognized_structure_type (Lisp_Object type)
2140 {
2141   int i;
2142
2143   for (i = 0; i < Dynarr_length (the_structure_type_dynarr); i++)
2144     {
2145       struct structure_type *st = Dynarr_atp (the_structure_type_dynarr, i);
2146       if (EQ (st->type, type))
2147         return st;
2148     }
2149
2150   return 0;
2151 }
2152
2153 static Lisp_Object
2154 read_structure (Lisp_Object readcharfun)
2155 {
2156   Emchar c = readchar (readcharfun);
2157   Lisp_Object list = Qnil;
2158   Lisp_Object orig_list = Qnil;
2159   Lisp_Object already_seen = Qnil;
2160   int keyword_count;
2161   struct structure_type *st;
2162   struct gcpro gcpro1, gcpro2;
2163
2164   GCPRO2 (orig_list, already_seen);
2165   if (c != '(')
2166     RETURN_UNGCPRO (continuable_read_syntax_error ("#s not followed by paren"));
2167   list = read_list (readcharfun, ')', 0, 0);
2168   orig_list = list;
2169   {
2170     int len = XINT (Flength (list));
2171     if (len == 0)
2172       RETURN_UNGCPRO (continuable_read_syntax_error
2173                       ("structure type not specified"));
2174     if (!(len & 1))
2175       RETURN_UNGCPRO
2176         (continuable_read_syntax_error
2177          ("structures must have alternating keyword/value pairs"));
2178   }
2179
2180   st = recognized_structure_type (XCAR (list));
2181   if (!st)
2182     RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2183                              list2 (build_translated_string
2184                                     ("unrecognized structure type"),
2185                                     XCAR (list))));
2186
2187   list = Fcdr (list);
2188   keyword_count = Dynarr_length (st->keywords);
2189   while (!NILP (list))
2190     {
2191       Lisp_Object keyword, value;
2192       int i;
2193       struct structure_keyword_entry *en = NULL;
2194
2195       keyword = Fcar (list);
2196       list = Fcdr (list);
2197       value = Fcar (list);
2198       list = Fcdr (list);
2199
2200       if (!NILP (memq_no_quit (keyword, already_seen)))
2201         RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2202                                  list2 (build_translated_string
2203                                         ("structure keyword already seen"),
2204                                         keyword)));
2205
2206       for (i = 0; i < keyword_count; i++)
2207         {
2208           en = Dynarr_atp (st->keywords, i);
2209           if (EQ (keyword, en->keyword))
2210             break;
2211         }
2212
2213       if (i == keyword_count)
2214         RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2215                                    list2 (build_translated_string
2216                                           ("unrecognized structure keyword"),
2217                                           keyword)));
2218
2219       if (en->validate && ! (en->validate) (keyword, value, ERROR_ME))
2220         RETURN_UNGCPRO
2221           (Fsignal (Qinvalid_read_syntax,
2222                     list3 (build_translated_string
2223                            ("invalid value for structure keyword"),
2224                            keyword, value)));
2225
2226       already_seen = Fcons (keyword, already_seen);
2227     }
2228
2229   if (st->validate && ! (st->validate) (orig_list, ERROR_ME))
2230     RETURN_UNGCPRO (Fsignal (Qinvalid_read_syntax,
2231                              list2 (build_translated_string
2232                                     ("invalid structure initializer"),
2233                                     orig_list)));
2234
2235   RETURN_UNGCPRO ((st->instantiate) (XCDR (orig_list)));
2236 }
2237
2238 \f
2239 static Lisp_Object read_compiled_function (Lisp_Object readcharfun,
2240                                            Emchar terminator);
2241 static Lisp_Object read_vector (Lisp_Object readcharfun, Emchar terminator);
2242
2243 /* Get the next character; filter out whitespace and comments */
2244
2245 static Emchar
2246 reader_nextchar (Lisp_Object readcharfun)
2247 {
2248   /* This function can GC */
2249   Emchar c;
2250
2251  retry:
2252   QUIT;
2253   c = readchar (readcharfun);
2254   if (c < 0)
2255     signal_error (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
2256
2257   switch (c)
2258     {
2259     default:
2260       {
2261         /* Ignore whitespace and control characters */
2262         if (c <= 040)
2263           goto retry;
2264         return c;
2265       }
2266
2267     case ';':
2268       {
2269         /* Comment */
2270         while ((c = readchar (readcharfun)) >= 0 && c != '\n')
2271           QUIT;
2272         goto retry;
2273       }
2274     }
2275 }
2276
2277 #if 0
2278 static Lisp_Object
2279 list2_pure (int pure, Lisp_Object a, Lisp_Object b)
2280 {
2281   return pure ? pure_cons (a, pure_cons (b, Qnil)) : list2 (a, b);
2282 }
2283 #endif
2284
2285 /* Read the next Lisp object from the stream READCHARFUN and return it.
2286    If the return value is a cons whose car is Qunbound, then read1()
2287    encountered a misplaced token (e.g. a right bracket, right paren,
2288    or dot followed by a non-number).  To filter this stuff out,
2289    use read0(). */
2290
2291 static Lisp_Object
2292 read1 (Lisp_Object readcharfun)
2293 {
2294   Emchar c;
2295
2296 retry:
2297   c = reader_nextchar (readcharfun);
2298
2299   switch (c)
2300     {
2301     case '(':
2302       {
2303 #ifdef LISP_BACKQUOTES  /* old backquote compatibility in lisp reader */
2304         /* if this is disabled, then other code in eval.c must be enabled */
2305         Emchar ch = reader_nextchar (readcharfun);
2306         switch (ch)
2307           {
2308           case '`':
2309             {
2310               Lisp_Object tem;
2311               int speccount = specpdl_depth ();
2312               ++old_backquote_flag;
2313               record_unwind_protect (backquote_unwind,
2314                                      make_opaque_ptr (&old_backquote_flag));
2315               tem = read0 (readcharfun);
2316               unbind_to (speccount, Qnil);
2317               ch = reader_nextchar (readcharfun);
2318               if (ch != ')')
2319                 {
2320                   unreadchar (readcharfun, ch);
2321                   return Fsignal (Qinvalid_read_syntax,
2322                                   list1 (build_string
2323                                          ("Weird old-backquote syntax")));
2324                 }
2325               return list2 (Qbacktick, tem);
2326             }
2327           case ',':
2328             {
2329               if (old_backquote_flag)
2330                 {
2331                   Lisp_Object tem, comma_type;
2332                   ch = readchar (readcharfun);
2333                   if (ch == '@')
2334                     comma_type = Qcomma_at;
2335                   else
2336                     {
2337                       if (ch >= 0)
2338                         unreadchar (readcharfun, ch);
2339                       comma_type = Qcomma;
2340                     }
2341                   tem = read0 (readcharfun);
2342                   ch = reader_nextchar (readcharfun);
2343                   if (ch != ')')
2344                     {
2345                       unreadchar (readcharfun, ch);
2346                       return Fsignal (Qinvalid_read_syntax,
2347                                       list1 (build_string
2348                                              ("Weird old-backquote syntax")));
2349                     }
2350                   return list2 (comma_type, tem);
2351                 }
2352               else
2353                 {
2354                   unreadchar (readcharfun, ch);
2355 #if 0
2356                   return Fsignal (Qinvalid_read_syntax,
2357                        list1 (build_string ("Comma outside of backquote")));
2358 #else
2359                   /* #### - yuck....but this is reverse compatible. */
2360                   /* mostly this is required by edebug, which does its own
2361                      annotated reading.  We need to have an annotated_read
2362                      function that records (with markers) the buffer
2363                      positions of the elements that make up lists, then that
2364                      can be used in edebug and bytecomp and the check above
2365                      can go back in. --Stig */
2366                   break;
2367 #endif
2368                 }
2369             }
2370           default:
2371             unreadchar (readcharfun, ch);
2372           }                     /* switch(ch) */
2373 #endif /* old backquote crap... */
2374         return read_list (readcharfun, ')', 1, 1);
2375       }
2376     case '[':
2377       return read_vector (readcharfun, ']');
2378
2379     case ')':
2380     case ']':
2381       /* #### - huh? these don't do what they seem... */
2382       return noseeum_cons (Qunbound, make_char (c));
2383     case '.':
2384       {
2385 #ifdef LISP_FLOAT_TYPE
2386         /* If a period is followed by a number, then we should read it
2387            as a floating point number.  Otherwise, it denotes a dotted
2388            pair.
2389          */
2390         c = readchar (readcharfun);
2391         unreadchar (readcharfun, c);
2392
2393         /* Can't use isdigit on Emchars */
2394         if (c < '0' || c > '9')
2395           return noseeum_cons (Qunbound, make_char ('.'));
2396
2397         /* Note that read_atom will loop
2398            at least once, assuring that we will not try to UNREAD
2399            two characters in a row.
2400            (I think this doesn't matter anymore because there should
2401            be no more danger in unreading multiple characters) */
2402         return read_atom (readcharfun, '.', 0);
2403
2404 #else /* ! LISP_FLOAT_TYPE */
2405         return noseeum_cons (Qunbound, make_char ('.'));
2406 #endif /* ! LISP_FLOAT_TYPE */
2407       }
2408
2409     case '#':
2410       {
2411         c = readchar (readcharfun);
2412         switch (c)
2413           {
2414 #if 0 /* FSFmacs silly char-table syntax */
2415           case '^':
2416 #endif
2417 #if 0 /* FSFmacs silly bool-vector syntax */
2418           case '&':
2419 #endif
2420             /* "#["-- byte-code constant syntax */
2421             /* purecons #[...] syntax */
2422           case '[': return read_compiled_function (readcharfun, ']'
2423                                                    /*, purify_flag */ );
2424             /* "#:"-- gensym syntax */
2425           case ':': return read_atom (readcharfun, -1, 1);
2426             /* #'x => (function x) */
2427           case '\'': return list2 (Qfunction, read0 (readcharfun));
2428 #if 0
2429             /* RMS uses this syntax for fat-strings.
2430                If we use it for vectors, then obscure bugs happen.
2431              */
2432             /* "#(" -- Scheme/CL vector syntax */
2433           case '(': return read_vector (readcharfun, ')');
2434 #endif
2435 #if 0 /* FSFmacs */
2436           case '(':
2437             {
2438               Lisp_Object tmp;
2439               struct gcpro gcpro1;
2440
2441               /* Read the string itself.  */
2442               tmp = read1 (readcharfun);
2443               if (!STRINGP (tmp))
2444                 {
2445                   if (CONSP (tmp) && UNBOUNDP (XCAR (tmp)))
2446                     free_cons (XCONS (tmp));
2447                   return Fsignal (Qinvalid_read_syntax,
2448                                    list1 (build_string ("#")));
2449                 }
2450               GCPRO1 (tmp);
2451               /* Read the intervals and their properties.  */
2452               while (1)
2453                 {
2454                   Lisp_Object beg, end, plist;
2455                   Emchar ch;
2456                   int invalid = 0;
2457
2458                   beg = read1 (readcharfun);
2459                   if (CONSP (beg) && UNBOUNDP (XCAR (beg)))
2460                     {
2461                       ch = XCHAR (XCDR (beg));
2462                       free_cons (XCONS (beg));
2463                       if (ch == ')')
2464                         break;
2465                       else
2466                         invalid = 1;
2467                     }
2468                   if (!invalid)
2469                     {
2470                       end = read1 (readcharfun);
2471                       if (CONSP (end) && UNBOUNDP (XCAR (end)))
2472                         {
2473                           free_cons (XCONS (end));
2474                           invalid = 1;
2475                         }
2476                     }
2477                   if (!invalid)
2478                     {
2479                       plist = read1 (readcharfun);
2480                       if (CONSP (plist) && UNBOUNDP (XCAR (plist)))
2481                         {
2482                           free_cons (XCONS (plist));
2483                           invalid = 1;
2484                         }
2485                     }
2486                   if (invalid)
2487                     RETURN_UNGCPRO
2488                       (Fsignal (Qinvalid_read_syntax,
2489                                 list2
2490                                 (build_string ("invalid string property list"),
2491                                  XCDR (plist))));
2492                   Fset_text_properties (beg, end, plist, tmp);
2493                 }
2494               UNGCPRO;
2495               return tmp;
2496             }
2497 #endif /* 0 */
2498           case '@':
2499             {
2500               /* #@NUMBER is used to skip NUMBER following characters.
2501                  That's used in .elc files to skip over doc strings
2502                  and function definitions.  */
2503               int i, nskip = 0;
2504
2505               /* Read a decimal integer.  */
2506               while ((c = readchar (readcharfun)) >= 0
2507                      && c >= '0' && c <= '9')
2508                 nskip = (10 * nskip) + (c - '0');
2509               if (c >= 0)
2510                 unreadchar (readcharfun, c);
2511
2512               /* FSF has code here that maybe caches the skipped
2513                  string.  See above for why this is totally
2514                  losing.  We handle this differently. */
2515
2516               /* Skip that many characters.  */
2517               for (i = 0; i < nskip && c >= 0; i++)
2518                 c = readchar (readcharfun);
2519
2520               goto retry;
2521             }
2522           case '$': return Vload_file_name_internal;
2523             /* bit vectors */
2524           case '*': return read_bit_vector (readcharfun);
2525             /* #o10 => 8 -- octal constant syntax */
2526           case 'o': return read_integer (readcharfun, 8);
2527             /* #xdead => 57005 -- hex constant syntax */
2528           case 'x': return read_integer (readcharfun, 16);
2529             /* #b010 => 2 -- binary constant syntax */
2530           case 'b': return read_integer (readcharfun, 2);
2531             /* #s(foobar key1 val1 key2 val2) -- structure syntax */
2532           case 's': return read_structure (readcharfun);
2533           case '<':
2534             {
2535               unreadchar (readcharfun, c);
2536               return Fsignal (Qinvalid_read_syntax,
2537                     list1 (build_string ("Cannot read unreadable object")));
2538             }
2539 #ifdef FEATUREP_SYNTAX
2540           case '+':
2541           case '-':
2542             {
2543               Lisp_Object feature_exp, obj, tem;
2544               struct gcpro gcpro1, gcpro2;
2545
2546               feature_exp = read0(readcharfun);
2547               obj = read0(readcharfun);
2548
2549               /* the call to `featurep' may GC. */
2550               GCPRO2 (feature_exp, obj);
2551               tem = call1 (Qfeaturep, feature_exp);
2552               UNGCPRO;
2553
2554               if (c == '+' &&  NILP(tem)) goto retry;
2555               if (c == '-' && !NILP(tem)) goto retry;
2556               return obj;
2557             }
2558 #endif
2559           case '0': case '1': case '2': case '3': case '4':
2560           case '5': case '6': case '7': case '8': case '9':
2561             /* Reader forms that can reuse previously read objects.  */
2562             {
2563               int n = 0;
2564               Lisp_Object found;
2565
2566               /* Using read_integer() here is impossible, because it
2567                  chokes on `='.  Using parse_integer() is too hard.
2568                  So we simply read it in, and ignore overflows, which
2569                  is safe.  */
2570               while (c >= '0' && c <= '9')
2571                 {
2572                   n *= 10;
2573                   n += c - '0';
2574                   c = readchar (readcharfun);
2575                 }
2576               found = assq_no_quit (make_int (n), Vread_objects);
2577               if (c == '=')
2578                 {
2579                   /* #n=object returns object, but associates it with
2580                      n for #n#.  */
2581                   Lisp_Object obj;
2582                   if (CONSP (found))
2583                     return Fsignal (Qinvalid_read_syntax,
2584                                     list2 (build_translated_string
2585                                            ("Multiply defined symbol label"),
2586                                            make_int (n)));
2587                   obj = read0 (readcharfun);
2588                   Vread_objects = Fcons (Fcons (make_int (n), obj),
2589                                          Vread_objects);
2590                   return obj;
2591                 }
2592               else if (c == '#')
2593                 {
2594                   /* #n# returns a previously read object.  */
2595                   if (CONSP (found))
2596                     return XCDR (found);
2597                   else
2598                     return Fsignal (Qinvalid_read_syntax,
2599                                     list2 (build_translated_string
2600                                            ("Undefined symbol label"),
2601                                            make_int (n)));
2602                 }
2603               return Fsignal (Qinvalid_read_syntax,
2604                               list1 (build_string ("#")));
2605             }
2606           default:
2607             {
2608               unreadchar (readcharfun, c);
2609               return Fsignal (Qinvalid_read_syntax,
2610                               list1 (build_string ("#")));
2611             }
2612           }
2613       }
2614
2615       /* Quote */
2616     case '\'': return list2 (Qquote, read0 (readcharfun));
2617
2618 #ifdef LISP_BACKQUOTES
2619     case '`':
2620       {
2621         Lisp_Object tem;
2622         int speccount = specpdl_depth ();
2623         ++new_backquote_flag;
2624         record_unwind_protect (backquote_unwind,
2625                                make_opaque_ptr (&new_backquote_flag));
2626         tem = read0 (readcharfun);
2627         unbind_to (speccount, Qnil);
2628         return list2 (Qbackquote, tem);
2629       }
2630
2631     case ',':
2632       {
2633         if (new_backquote_flag)
2634           {
2635             Lisp_Object comma_type = Qnil;
2636             int ch = readchar (readcharfun);
2637
2638             if (ch == '@')
2639               comma_type = Qcomma_at;
2640             else if (ch == '.')
2641               comma_type = Qcomma_dot;
2642             else
2643               {
2644                 if (ch >= 0)
2645                   unreadchar (readcharfun, ch);
2646                 comma_type = Qcomma;
2647               }
2648             return list2 (comma_type, read0 (readcharfun));
2649           }
2650         else
2651           {
2652             /* YUCK.  99.999% backwards compatibility.  The Right
2653                Thing(tm) is to signal an error here, because it's
2654                really invalid read syntax.  Instead, this permits
2655                commas to begin symbols (unless they're inside
2656                backquotes).  If an error is signalled here in the
2657                future, then commas should be invalid read syntax
2658                outside of backquotes anywhere they're found (i.e.
2659                they must be quoted in symbols) -- Stig */
2660             return read_atom (readcharfun, c, 0);
2661           }
2662       }
2663 #endif
2664
2665     case '?':
2666       {
2667         /* Evil GNU Emacs "character" (ie integer) syntax */
2668         c = readchar (readcharfun);
2669         if (c < 0)
2670           return Fsignal (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
2671
2672         if (c == '\\')
2673           c = read_escape (readcharfun);
2674         return make_char (c);
2675       }
2676
2677     case '\"':
2678       {
2679         /* String */
2680 #ifdef I18N3
2681         /* #### If the input stream is translating, then the string
2682            should be marked as translatable by setting its
2683            `string-translatable' property to t.  .el and .elc files
2684            normally are translating input streams.  See Fgettext()
2685            and print_internal(). */
2686 #endif
2687         int cancel = 0;
2688
2689         Lstream_rewind (XLSTREAM (Vread_buffer_stream));
2690         while ((c = readchar (readcharfun)) >= 0
2691                && c != '\"')
2692           {
2693             if (c == '\\')
2694               c = read_escape (readcharfun);
2695             /* c is -1 if \ newline has just been seen */
2696             if (c == -1)
2697               {
2698                 if (Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) == 0)
2699                   cancel = 1;
2700               }
2701             else
2702               Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
2703             QUIT;
2704           }
2705         if (c < 0)
2706           return Fsignal (Qend_of_file, list1 (READCHARFUN_MAYBE (readcharfun)));
2707
2708         /* If purifying, and string starts with \ newline,
2709            return zero instead.  This is for doc strings
2710            that we are really going to find in lib-src/DOC.nn.nn  */
2711         if (purify_flag && NILP (Vinternal_doc_file_name) && cancel)
2712           return Qzero;
2713
2714         Lstream_flush (XLSTREAM (Vread_buffer_stream));
2715         return
2716           make_string
2717           (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
2718            Lstream_byte_count (XLSTREAM (Vread_buffer_stream)));
2719       }
2720
2721     default:
2722       {
2723         /* Ignore whitespace and control characters */
2724         if (c <= 040)
2725           goto retry;
2726         return read_atom (readcharfun, c, 0);
2727       }
2728     }
2729 }
2730
2731
2732 \f
2733 #ifdef LISP_FLOAT_TYPE
2734
2735 #define LEAD_INT 1
2736 #define DOT_CHAR 2
2737 #define TRAIL_INT 4
2738 #define E_CHAR 8
2739 #define EXP_INT 16
2740
2741 int
2742 isfloat_string (const char *cp)
2743 {
2744   int state = 0;
2745   const Bufbyte *ucp = (const Bufbyte *) cp;
2746
2747   if (*ucp == '+' || *ucp == '-')
2748     ucp++;
2749
2750   if (*ucp >= '0' && *ucp <= '9')
2751     {
2752       state |= LEAD_INT;
2753       while (*ucp >= '0' && *ucp <= '9')
2754         ucp++;
2755     }
2756   if (*ucp == '.')
2757     {
2758       state |= DOT_CHAR;
2759       ucp++;
2760     }
2761   if (*ucp >= '0' && *ucp <= '9')
2762     {
2763       state |= TRAIL_INT;
2764       while (*ucp >= '0' && *ucp <= '9')
2765         ucp++;
2766     }
2767   if (*ucp == 'e' || *ucp == 'E')
2768     {
2769       state |= E_CHAR;
2770       ucp++;
2771       if ((*ucp == '+') || (*ucp == '-'))
2772         ucp++;
2773     }
2774
2775   if (*ucp >= '0' && *ucp <= '9')
2776     {
2777       state |= EXP_INT;
2778       while (*ucp >= '0' && *ucp <= '9')
2779         ucp++;
2780     }
2781   return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') || (*ucp == '\n')
2782            || (*ucp == '\r') || (*ucp == '\f'))
2783           && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
2784               || state == (DOT_CHAR|TRAIL_INT)
2785               || state == (LEAD_INT|E_CHAR|EXP_INT)
2786               || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
2787               || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
2788 }
2789 #endif /* LISP_FLOAT_TYPE */
2790 \f
2791 static void *
2792 sequence_reader (Lisp_Object readcharfun,
2793                  Emchar terminator,
2794                  void *state,
2795                  void * (*conser) (Lisp_Object readcharfun,
2796                                    void *state, Charcount len))
2797 {
2798   Charcount len;
2799
2800   for (len = 0; ; len++)
2801     {
2802       Emchar ch;
2803
2804       QUIT;
2805       ch = reader_nextchar (readcharfun);
2806
2807       if (ch == terminator)
2808         return state;
2809       else
2810         unreadchar (readcharfun, ch);
2811 #ifdef FEATUREP_SYNTAX
2812       if (ch == ']')
2813         read_syntax_error ("\"]\" in a list");
2814       else if (ch == ')')
2815         read_syntax_error ("\")\" in a vector");
2816 #endif
2817       state = ((conser) (readcharfun, state, len));
2818     }
2819 }
2820
2821
2822 struct read_list_state
2823   {
2824     Lisp_Object head;
2825     Lisp_Object tail;
2826     int length;
2827     int allow_dotted_lists;
2828     Emchar terminator;
2829   };
2830
2831 static void *
2832 read_list_conser (Lisp_Object readcharfun, void *state, Charcount len)
2833 {
2834   struct read_list_state *s = (struct read_list_state *) state;
2835   Lisp_Object elt;
2836
2837   elt = read1 (readcharfun);
2838
2839   if (CONSP (elt) && UNBOUNDP (XCAR (elt)))
2840     {
2841       Lisp_Object tem = elt;
2842       Emchar ch;
2843
2844       elt = XCDR (elt);
2845       free_cons (XCONS (tem));
2846       tem = Qnil;
2847       ch = XCHAR (elt);
2848 #ifdef FEATUREP_SYNTAX
2849       if (ch == s->terminator) /* deal with #+, #- reader macros */
2850         {
2851           unreadchar (readcharfun, s->terminator);
2852           goto done;
2853         }
2854       else if (ch == ']')
2855         read_syntax_error ("']' in a list");
2856       else if (ch == ')')
2857         read_syntax_error ("')' in a vector");
2858       else
2859 #endif
2860       if (ch != '.')
2861         signal_simple_error ("BUG! Internal reader error", elt);
2862       else if (!s->allow_dotted_lists)
2863         read_syntax_error ("\".\" in a vector");
2864       else
2865         {
2866           if (!NILP (s->tail))
2867             XCDR (s->tail) = read0 (readcharfun);
2868           else
2869             s->head = read0 (readcharfun);
2870           elt = read1 (readcharfun);
2871           if (CONSP (elt) && UNBOUNDP (XCAR (elt)))
2872             {
2873               ch = XCHAR (XCDR (elt));
2874               free_cons (XCONS (elt));
2875               if (ch == s->terminator)
2876                 {
2877                   unreadchar (readcharfun, s->terminator);
2878                   goto done;
2879                 }
2880             }
2881           read_syntax_error (". in wrong context");
2882         }
2883     }
2884
2885 #if 0 /* FSFmacs defun hack, or something ... */
2886   if (NILP (tail) && defun_hack && EQ (elt, Qdefun) && !read_pure)
2887     {
2888       record_unwind_protect (unreadpure, Qzero);
2889       read_pure = 1;
2890     }
2891 #endif
2892
2893 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2894   if (s->length == 1 && s->allow_dotted_lists && EQ (XCAR (s->head), Qfset))
2895     {
2896       if (CONSP (elt) && EQ (XCAR (elt), Qquote) && CONSP (XCDR (elt)))
2897         Vcurrent_compiled_function_annotation = XCAR (XCDR (elt));
2898       else
2899         Vcurrent_compiled_function_annotation = elt;
2900     }
2901 #endif
2902
2903   elt = Fcons (elt, Qnil);
2904   if (!NILP (s->tail))
2905     XCDR (s->tail) = elt;
2906   else
2907     s->head = elt;
2908   s->tail = elt;
2909  done:
2910   s->length++;
2911   return s;
2912 }
2913
2914 \f
2915 #if 0 /* FSFmacs defun hack */
2916 /* -1 for allow_dotted_lists means allow_dotted_lists and check
2917    for starting with defun and make structure pure. */
2918 #endif
2919
2920 static Lisp_Object
2921 read_list (Lisp_Object readcharfun,
2922            Emchar terminator,
2923            int allow_dotted_lists,
2924            int check_for_doc_references)
2925 {
2926   struct read_list_state s;
2927   struct gcpro gcpro1, gcpro2;
2928 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2929   Lisp_Object old_compiled_function_annotation =
2930     Vcurrent_compiled_function_annotation;
2931 #endif
2932
2933   s.head = Qnil;
2934   s.tail = Qnil;
2935   s.length = 0;
2936   s.allow_dotted_lists = allow_dotted_lists;
2937   s.terminator = terminator;
2938   GCPRO2 (s.head, s.tail);
2939
2940   sequence_reader (readcharfun, terminator, &s, read_list_conser);
2941 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2942   Vcurrent_compiled_function_annotation = old_compiled_function_annotation;
2943 #endif
2944
2945   if ((purify_flag || load_force_doc_strings) && check_for_doc_references)
2946     {
2947       /* check now for any doc string references and record them
2948          for later. */
2949       Lisp_Object tail;
2950
2951       /* We might be dealing with an imperfect list so don't
2952          use LIST_LOOP */
2953       for (tail = s.head; CONSP (tail); tail = XCDR (tail))
2954         {
2955           Lisp_Object holding_cons = Qnil;
2956
2957           {
2958             Lisp_Object elem = XCAR (tail);
2959             /* elem might be (#$ . INT) ... */
2960             if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal))
2961               holding_cons = tail;
2962             /* or it might be (quote (#$ . INT)) i.e.
2963                (quote . ((#$ . INT) . nil)) in the case of
2964                `autoload' (autoload evaluates its arguments, while
2965                `defvar', `defun', etc. don't). */
2966             if (CONSP (elem) && EQ (XCAR (elem), Qquote)
2967                 && CONSP (XCDR (elem)))
2968               {
2969                 elem = XCAR (XCDR (elem));
2970                 if (CONSP (elem) && EQ (XCAR (elem), Vload_file_name_internal))
2971                   holding_cons = XCDR (XCAR (tail));
2972               }
2973           }
2974
2975           if (CONSP (holding_cons))
2976             {
2977               if (purify_flag)
2978                 {
2979                   if (NILP (Vinternal_doc_file_name))
2980                     /* We have not yet called Snarf-documentation, so
2981                        assume this file is described in the DOC file
2982                        and Snarf-documentation will fill in the right
2983                        value later.  For now, replace the whole list
2984                        with 0.  */
2985                     XCAR (holding_cons) = Qzero;
2986                   else
2987                     /* We have already called Snarf-documentation, so
2988                        make a relative file name for this file, so it
2989                        can be found properly in the installed Lisp
2990                        directory.  We don't use Fexpand_file_name
2991                        because that would make the directory absolute
2992                        now.  */
2993                     XCAR (XCAR (holding_cons)) =
2994                       concat2 (build_string ("../lisp/"),
2995                                Ffile_name_nondirectory
2996                                (Vload_file_name_internal));
2997                 }
2998               else
2999                 /* Not pure.  Just add to Vload_force_doc_string_list,
3000                    and the string will be filled in properly in
3001                    load_force_doc_string_unwind(). */
3002                 Vload_force_doc_string_list =
3003                   /* We pass the cons that holds the (#$ . INT) so we
3004                      can modify it in-place. */
3005                   Fcons (holding_cons, Vload_force_doc_string_list);
3006             }
3007         }
3008     }
3009
3010   UNGCPRO;
3011   return s.head;
3012 }
3013
3014 static Lisp_Object
3015 read_vector (Lisp_Object readcharfun,
3016              Emchar terminator)
3017 {
3018   Lisp_Object tem;
3019   Lisp_Object *p;
3020   int len;
3021   int i;
3022   struct read_list_state s;
3023   struct gcpro gcpro1, gcpro2;
3024
3025   s.head = Qnil;
3026   s.tail = Qnil;
3027   s.length = 0;
3028   s.allow_dotted_lists = 0;
3029   GCPRO2 (s.head, s.tail);
3030
3031   sequence_reader (readcharfun, terminator, &s, read_list_conser);
3032
3033   UNGCPRO;
3034   tem = s.head;
3035   len = XINT (Flength (tem));
3036
3037 #if 0 /* FSFmacs defun hack */
3038   if (read_pure)
3039     s.head = make_pure_vector (len, Qnil);
3040   else
3041 #endif
3042     s.head = make_vector (len, Qnil);
3043
3044   for (i = 0, p = &(XVECTOR_DATA (s.head)[0]);
3045        i < len;
3046        i++, p++)
3047   {
3048     Lisp_Cons *otem = XCONS (tem);
3049     tem = Fcar (tem);
3050     *p = tem;
3051     tem = otem->cdr;
3052     free_cons (otem);
3053   }
3054   return s.head;
3055 }
3056
3057 static Lisp_Object
3058 read_compiled_function (Lisp_Object readcharfun, Emchar terminator)
3059 {
3060   /* Accept compiled functions at read-time so that we don't
3061      have to build them at load-time. */
3062   Lisp_Object stuff;
3063   Lisp_Object make_byte_code_args[COMPILED_DOMAIN + 1];
3064   struct gcpro gcpro1;
3065   int len;
3066   int iii;
3067   int saw_a_doc_ref = 0;
3068
3069   /* Note: we tell read_list not to search for doc references
3070      because we need to handle the "doc reference" for the
3071      instructions and constants differently. */
3072   stuff = read_list (readcharfun, terminator, 0, 0);
3073   len = XINT (Flength (stuff));
3074   if (len < COMPILED_STACK_DEPTH + 1 || len > COMPILED_DOMAIN + 1)
3075     return
3076       continuable_read_syntax_error ("#[...] used with wrong number of elements");
3077
3078   for (iii = 0; CONSP (stuff); iii++)
3079     {
3080       Lisp_Cons *victim = XCONS (stuff);
3081       make_byte_code_args[iii] = Fcar (stuff);
3082       if ((purify_flag || load_force_doc_strings)
3083            && CONSP (make_byte_code_args[iii])
3084           && EQ (XCAR (make_byte_code_args[iii]), Vload_file_name_internal))
3085         {
3086           if (purify_flag && iii == COMPILED_DOC_STRING)
3087             {
3088               /* same as in read_list(). */
3089               if (NILP (Vinternal_doc_file_name))
3090                 make_byte_code_args[iii] = Qzero;
3091               else
3092                 XCAR (make_byte_code_args[iii]) =
3093                   concat2 (build_string ("../lisp/"),
3094                            Ffile_name_nondirectory
3095                            (Vload_file_name_internal));
3096             }
3097           else
3098             saw_a_doc_ref = 1;
3099         }
3100       stuff = Fcdr (stuff);
3101       free_cons (victim);
3102     }
3103   GCPRO1 (make_byte_code_args[0]);
3104   gcpro1.nvars = len;
3105
3106   /* v18 or v19 bytecode file.  Need to Ebolify. */
3107   if (load_byte_code_version < 20 && VECTORP (make_byte_code_args[2]))
3108     ebolify_bytecode_constants (make_byte_code_args[2]);
3109
3110   /* make-byte-code looks at purify_flag, which should have the same
3111    *  value as our "read-pure" argument */
3112   stuff = Fmake_byte_code (len, make_byte_code_args);
3113   XCOMPILED_FUNCTION (stuff)->flags.ebolified = (load_byte_code_version < 20);
3114   if (saw_a_doc_ref)
3115     Vload_force_doc_string_list = Fcons (stuff, Vload_force_doc_string_list);
3116   UNGCPRO;
3117   return stuff;
3118 }
3119
3120
3121 \f
3122 void
3123 init_lread (void)
3124 {
3125   Vvalues = Qnil;
3126
3127   load_in_progress = 0;
3128
3129   Vload_descriptor_list = Qnil;
3130
3131   /* kludge: locate-file does not work for a null load-path, even if
3132      the file name is absolute. */
3133
3134   Vload_path = Fcons (build_string (""), Qnil);
3135
3136   /* This used to get initialized in init_lread because all streams
3137      got closed when dumping occurs.  This is no longer true --
3138      Vread_buffer_stream is a resizing output stream, and there is no
3139      reason to close it at dump-time.
3140
3141      Vread_buffer_stream is set to Qnil in vars_of_lread, and this
3142      will initialize it only once, at dump-time.  */
3143   if (NILP (Vread_buffer_stream))
3144     Vread_buffer_stream = make_resizing_buffer_output_stream ();
3145
3146   Vload_force_doc_string_list = Qnil;
3147 }
3148
3149 void
3150 syms_of_lread (void)
3151 {
3152   DEFSUBR (Fread);
3153   DEFSUBR (Fread_from_string);
3154   DEFSUBR (Fload_internal);
3155   DEFSUBR (Flocate_file);
3156   DEFSUBR (Flocate_file_clear_hashing);
3157   DEFSUBR (Feval_buffer);
3158   DEFSUBR (Feval_region);
3159
3160   defsymbol (&Qstandard_input, "standard-input");
3161   defsymbol (&Qread_char, "read-char");
3162   defsymbol (&Qcurrent_load_list, "current-load-list");
3163   defsymbol (&Qload, "load");
3164   defsymbol (&Qload_file_name, "load-file-name");
3165   defsymbol (&Qfset, "fset");
3166
3167 #ifdef LISP_BACKQUOTES
3168   defsymbol (&Qbackquote, "backquote");
3169   defsymbol (&Qbacktick, "`");
3170   defsymbol (&Qcomma, ",");
3171   defsymbol (&Qcomma_at, ",@");
3172   defsymbol (&Qcomma_dot, ",.");
3173 #endif
3174
3175   defsymbol (&Qexists, "exists");
3176   defsymbol (&Qreadable, "readable");
3177   defsymbol (&Qwritable, "writable");
3178   defsymbol (&Qexecutable, "executable");
3179 }
3180
3181 void
3182 structure_type_create (void)
3183 {
3184   the_structure_type_dynarr = Dynarr_new (structure_type);
3185 }
3186
3187 void
3188 reinit_vars_of_lread (void)
3189 {
3190   Vread_buffer_stream = Qnil;
3191   staticpro_nodump (&Vread_buffer_stream);
3192 }
3193
3194 void
3195 vars_of_lread (void)
3196 {
3197   reinit_vars_of_lread ();
3198
3199   DEFVAR_LISP ("values", &Vvalues /*
3200 List of values of all expressions which were read, evaluated and printed.
3201 Order is reverse chronological.
3202 */ );
3203
3204   DEFVAR_LISP ("standard-input", &Vstandard_input /*
3205 Stream for read to get input from.
3206 See documentation of `read' for possible values.
3207 */ );
3208   Vstandard_input = Qt;
3209
3210   DEFVAR_LISP ("load-path", &Vload_path /*
3211 *List of directories to search for files to load.
3212 Each element is a string (directory name) or nil (try default directory).
3213
3214 Note that the elements of this list *may not* begin with "~", so you must
3215 call `expand-file-name' on them before adding them to this list.
3216
3217 Initialized based on EMACSLOADPATH environment variable, if any,
3218 otherwise to default specified in by file `paths.h' when XEmacs was built.
3219 If there were no paths specified in `paths.h', then XEmacs chooses a default
3220 value for this variable by looking around in the file-system near the
3221 directory in which the XEmacs executable resides.
3222 */ );
3223   Vload_path = Qnil;
3224
3225 /*  xxxDEFVAR_LISP ("dump-load-path", &Vdump_load_path,
3226     "*Location of lisp files to be used when dumping ONLY."); */
3227
3228   DEFVAR_BOOL ("load-in-progress", &load_in_progress /*
3229 Non-nil iff inside of `load'.
3230 */ );
3231
3232   DEFVAR_LISP ("after-load-alist", &Vafter_load_alist /*
3233 An alist of expressions to be evalled when particular files are loaded.
3234 Each element looks like (FILENAME FORMS...).
3235 When `load' is run and the file-name argument is FILENAME,
3236 the FORMS in the corresponding element are executed at the end of loading.
3237
3238 FILENAME must match exactly!  Normally FILENAME is the name of a library,
3239 with no directory specified, since that is how `load' is normally called.
3240 An error in FORMS does not undo the load,
3241 but does prevent execution of the rest of the FORMS.
3242 */ );
3243   Vafter_load_alist = Qnil;
3244
3245   DEFVAR_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer /*
3246 *Whether `load' should check whether the source is newer than the binary.
3247 If this variable is true, then when a `.elc' file is being loaded and the
3248 corresponding `.el' is newer, a warning message will be printed.
3249 */ );
3250   load_warn_when_source_newer = 0;
3251
3252   DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only /*
3253 *Whether `load' should warn when loading a `.el' file instead of an `.elc'.
3254 If this variable is true, then when `load' is called with a filename without
3255 an extension, and the `.elc' version doesn't exist but the `.el' version does,
3256 then a message will be printed.  If an explicit extension is passed to `load',
3257 no warning will be printed.
3258 */ );
3259   load_warn_when_source_only = 0;
3260
3261   DEFVAR_BOOL ("load-ignore-elc-files", &load_ignore_elc_files /*
3262 *Whether `load' should ignore `.elc' files when a suffix is not given.
3263 This is normally used only to bootstrap the `.elc' files when building XEmacs.
3264 */ );
3265   load_ignore_elc_files = 0;
3266
3267 #ifdef LOADHIST
3268   DEFVAR_LISP ("load-history", &Vload_history /*
3269 Alist mapping source file names to symbols and features.
3270 Each alist element is a list that starts with a file name,
3271 except for one element (optional) that starts with nil and describes
3272 definitions evaluated from buffers not visiting files.
3273 The remaining elements of each list are symbols defined as functions
3274 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.
3275 */ );
3276   Vload_history = Qnil;
3277
3278   DEFVAR_LISP ("current-load-list", &Vcurrent_load_list /*
3279 Used for internal purposes by `load'.
3280 */ );
3281   Vcurrent_load_list = Qnil;
3282 #endif
3283
3284   DEFVAR_LISP ("load-file-name", &Vload_file_name /*
3285 Full name of file being loaded by `load'.
3286 */ );
3287   Vload_file_name = Qnil;
3288
3289   DEFVAR_LISP ("load-read-function", &Vload_read_function /*
3290 Function used by `load' and `eval-region' for reading expressions.
3291 The default is nil, which means use the function `read'.
3292 */ );
3293   Vload_read_function = Qnil;
3294
3295   DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings /*
3296 Non-nil means `load' should force-load all dynamic doc strings.
3297 This is useful when the file being loaded is a temporary copy.
3298 */ );
3299   load_force_doc_strings = 0;
3300
3301   /* See read_escape().  */
3302 #if 0
3303   /* Used to be named `puke-on-fsf-keys' */
3304   DEFVAR_BOOL ("fail-on-bucky-bit-character-escapes",
3305                &fail_on_bucky_bit_character_escapes /*
3306 Whether `read' should signal an error when it encounters unsupported
3307 character escape syntaxes or just read them incorrectly.
3308 */ );
3309   fail_on_bucky_bit_character_escapes = 0;
3310 #endif
3311
3312   /* This must be initialized in init_lread otherwise it may start out
3313      with values saved when the image is dumped. */
3314   staticpro (&Vload_descriptor_list);
3315
3316   /* Initialized in init_lread. */
3317   staticpro (&Vload_force_doc_string_list);
3318
3319   Vload_file_name_internal = Qnil;
3320   staticpro (&Vload_file_name_internal);
3321
3322   Vload_file_name_internal_the_purecopy = Qnil;
3323   staticpro (&Vload_file_name_internal_the_purecopy);
3324
3325 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3326   Vcurrent_compiled_function_annotation = Qnil;
3327   staticpro (&Vcurrent_compiled_function_annotation);
3328 #endif
3329
3330   /* So that early-early stuff will work */
3331   Ffset (Qload, intern ("load-internal"));
3332
3333 #ifdef FEATUREP_SYNTAX
3334   defsymbol (&Qfeaturep, "featurep");
3335   Fprovide(intern("xemacs"));
3336 #ifdef INFODOCK
3337   Fprovide(intern("infodock"));
3338 #endif /* INFODOCK */
3339 #endif /* FEATUREP_SYNTAX */
3340
3341 #ifdef LISP_BACKQUOTES
3342   old_backquote_flag = new_backquote_flag = 0;
3343 #endif
3344
3345 #ifdef I18N3
3346   Vfile_domain = Qnil;
3347 #endif
3348
3349   Vread_objects = Qnil;
3350   staticpro (&Vread_objects);
3351
3352   Vlocate_file_hash_table = make_lisp_hash_table (200,
3353                                                   HASH_TABLE_NON_WEAK,
3354                                                   HASH_TABLE_EQUAL);
3355   staticpro (&Vlocate_file_hash_table);
3356 #ifdef DEBUG_XEMACS
3357   symbol_value (XSYMBOL (intern ("Vlocate-file-hash-table")))
3358     = Vlocate_file_hash_table;
3359 #endif
3360 }