comparison src/lread.c @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ee648375d8d6
children 54cc21c15cbb
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
33 #include "commands.h" 33 #include "commands.h"
34 #include "insdel.h" 34 #include "insdel.h"
35 #include "lstream.h" 35 #include "lstream.h"
36 #include "opaque.h" 36 #include "opaque.h"
37 #include "paths.h" 37 #include "paths.h"
38 #endif
39 #ifdef MULE
40 #include "mule-coding.h"
38 #endif 41 #endif
39 42
40 #include "sysfile.h" 43 #include "sysfile.h"
41 44
42 #ifdef LISP_FLOAT_TYPE 45 #ifdef LISP_FLOAT_TYPE
67 Lisp_Object Qload, Qload_file_name; 70 Lisp_Object Qload, Qload_file_name;
68 Lisp_Object Qlocate_file_hash_table; 71 Lisp_Object Qlocate_file_hash_table;
69 Lisp_Object Qfset; 72 Lisp_Object Qfset;
70 73
71 int puke_on_fsf_keys; 74 int puke_on_fsf_keys;
72
73 /* This symbol is also used in fns.c */
74 #define FEATUREP_SYNTAX
75
76 #ifdef FEATUREP_SYNTAX
77 static Lisp_Object Qfeaturep;
78 #endif
79 75
80 /* non-zero if inside `load' */ 76 /* non-zero if inside `load' */
81 int load_in_progress; 77 int load_in_progress;
82 78
83 /* Whether Fload_internal() should check whether the .el is newer 79 /* Whether Fload_internal() should check whether the .el is newer
373 Vload_file_name_internal_the_purecopy = oldval; 369 Vload_file_name_internal_the_purecopy = oldval;
374 return Qnil; 370 return Qnil;
375 } 371 }
376 372
377 static Lisp_Object 373 static Lisp_Object
374 load_byte_code_version_unwind (Lisp_Object oldval)
375 {
376 load_byte_code_version = XINT (oldval);
377 return Qnil;
378 }
379
380 /* The plague is coming.
381
382 Ring around the rosy, pocket full of posy,
383 Ashes ashes, they all fall down.
384 */
385 void
386 ebolify_bytecode_constants (Lisp_Object vector)
387 {
388 int len = vector_length (XVECTOR (vector));
389 int i;
390
391 for (i = 0; i < len; i++)
392 {
393 Lisp_Object el = vector_data (XVECTOR (vector))[i];
394
395 /* We don't check for `eq', `equal', and the others that have
396 bytecode opcodes. This might lose if someone passes #'eq or
397 something to `funcall', but who would really do that? As
398 they say in law, we've made a "good-faith effort" to
399 unfuckify ourselves. And doing it this way avoids screwing
400 up args to `make-hashtable' and such. As it is, we have to
401 add an extra Ebola check in decode_weak_list_type(). --ben */
402 if (EQ (el, Qassoc))
403 el = Qold_assoc;
404 if (EQ (el, Qdelq))
405 el = Qold_delq;
406 #if 0
407 /* I think this is a bad idea because it will probably mess
408 with keymap code. */
409 if (EQ (el, Qdelete))
410 el = Qold_delete;
411 #endif
412 if (EQ (el, Qrassq))
413 el = Qold_rassq;
414 if (EQ (el, Qrassoc))
415 el = Qold_rassoc;
416 vector_data (XVECTOR (vector))[i] = el;
417 }
418 }
419
420 static Lisp_Object
378 pas_de_lache_ici (int fd, Lisp_Object victim) 421 pas_de_lache_ici (int fd, Lisp_Object victim)
379 { 422 {
380 Lisp_Object tem; 423 Lisp_Object tem;
381 EMACS_INT pos; 424 EMACS_INT pos;
382 425
434 ivan = Fread (juan); 477 ivan = Fread (juan);
435 if (!CONSP (ivan)) 478 if (!CONSP (ivan))
436 signal_simple_error ("invalid lazy-loaded byte code", ivan); 479 signal_simple_error ("invalid lazy-loaded byte code", ivan);
437 /* Remember to purecopy; see above. */ 480 /* Remember to purecopy; see above. */
438 XCOMPILED_FUNCTION (john)->bytecodes = Fpurecopy (XCAR (ivan)); 481 XCOMPILED_FUNCTION (john)->bytecodes = Fpurecopy (XCAR (ivan));
482 /* v18 or v19 bytecode file. Need to Ebolify. */
483 if (XCOMPILED_FUNCTION (john)->flags.ebolified
484 && VECTORP (XCDR (ivan)))
485 ebolify_bytecode_constants (XCDR (ivan));
439 XCOMPILED_FUNCTION (john)->constants = Fpurecopy (XCDR (ivan)); 486 XCOMPILED_FUNCTION (john)->constants = Fpurecopy (XCDR (ivan));
440 NUNGCPRO; 487 NUNGCPRO;
441 } 488 }
442 doc = compiled_function_documentation (XCOMPILED_FUNCTION (john)); 489 doc = compiled_function_documentation (XCOMPILED_FUNCTION (john));
443 if (CONSP (doc)) 490 if (CONSP (doc))
478 Vfile_domain = val; 525 Vfile_domain = val;
479 return Qnil; 526 return Qnil;
480 } 527 }
481 #endif /* I18N3 */ 528 #endif /* I18N3 */
482 529
483 DEFUN ("load-internal", Fload_internal, 1, 4, 0, /* 530 DEFUN ("load-internal", Fload_internal, 1, 6, 0, /*
484 Execute a file of Lisp code named FILE. 531 Execute a file of Lisp code named FILE; no coding-system frobbing.
485 First try FILE with `.elc' appended, then try with `.el', 532 This function is identical to `load' except for the handling of the
486 then try FILE unmodified. 533 CODESYS and USED-CODESYS arguments under XEmacs/Mule. (When Mule
487 This function searches the directories in `load-path'. 534 support is not present, both functions are identical and ignore the
488 If optional second arg NOERROR is non-nil, 535 CODESYS and USED-CODESYS arguments.)
489 report no error if FILE doesn't exist. 536
490 Print messages at start and end of loading unless 537 If support for Mule exists in this Emacs, the file is decoded
491 optional third arg NOMESSAGE is non-nil (ignored in -batch mode). 538 according to CODESYS; if omitted, no conversion happens. If
492 If optional fourth arg NOSUFFIX is non-nil, don't try adding 539 USED-CODESYS is non-nil, it should be a symbol, and the actual coding
493 suffixes `.elc' or `.el' to the specified name FILE. 540 system that was used for the decoding is stored into it. It will in
494 Return t if file exists. 541 general be different from CODESYS if CODESYS specifies automatic
542 encoding detection or end-of-line detection.
495 */ 543 */
496 (file, no_error, nomessage, nosuffix)) 544 (file, no_error, nomessage, nosuffix, codesys, used_codesys))
497 { 545 {
498 /* This function can GC */ 546 /* This function can GC */
499 int fd = -1; 547 int fd = -1;
500 int speccount = specpdl_depth (); 548 int speccount = specpdl_depth ();
501 int source_only = 0; 549 int source_only = 0;
526 #endif /* DEBUG_XEMACS */ 574 #endif /* DEBUG_XEMACS */
527 575
528 /* If file name is magic, call the handler. */ 576 /* If file name is magic, call the handler. */
529 handler = Ffind_file_name_handler (file, Qload); 577 handler = Ffind_file_name_handler (file, Qload);
530 if (!NILP (handler)) 578 if (!NILP (handler))
531 RETURN_UNGCPRO (call5 (handler, Qload, file, no_error, 579 RETURN_UNGCPRO (call7 (handler, Qload, file, no_error, nomessage,
532 nomessage, nosuffix)); 580 nosuffix, codesys, used_codesys));
533 581
534 /* Do this after the handler to avoid 582 /* Do this after the handler to avoid
535 the need to gcpro noerror, nomessage and nosuffix. 583 the need to gcpro noerror, nomessage and nosuffix.
536 (Below here, we care only whether they are nil or not.) */ 584 (Below here, we care only whether they are nil or not.) */
537 file = Fsubstitute_in_file_name (file); 585 file = Fsubstitute_in_file_name (file);
538 586
587 #ifdef MULE
588 if (!NILP (used_codesys))
589 CHECK_SYMBOL (used_codesys);
590 #endif
539 591
540 /* Avoid weird lossage with null string as arg, 592 /* Avoid weird lossage with null string as arg,
541 since it would try to load a directory as a Lisp file. 593 since it would try to load a directory as a Lisp file.
542 Unix truly sucks. */ 594 Unix truly sucks. */
543 if (XSTRING_LENGTH (file) > 0) 595 if (XSTRING_LENGTH (file) > 0)
618 to reopen it in text mode. */ 670 to reopen it in text mode. */
619 if (!reading_elc) 671 if (!reading_elc)
620 fd = open (foundstr, O_RDONLY | O_TEXT); 672 fd = open (foundstr, O_RDONLY | O_TEXT);
621 #endif /* DOS_NT */ 673 #endif /* DOS_NT */
622 674
623 #define PRINT_LOADING_MESSAGE(done) do { \ 675 #define PRINT_LOADING_MESSAGE(done) do { \
624 if (load_ignore_elc_files) \ 676 if (load_ignore_elc_files) \
625 { \ 677 { \
626 if (message_p) \ 678 if (message_p) \
627 message ("Loading %s..." done, XSTRING_DATA (newer)); \ 679 message ("Loading %s..." done, XSTRING_DATA (newer)); \
628 } \ 680 } \
629 else if (!NILP (newer)) \ 681 else if (!NILP (newer)) \
630 message ("Loading %s..." done " (file %s is newer)", \ 682 message ("Loading %s..." done " (file %s is newer)", \
631 XSTRING_DATA (file), \ 683 XSTRING_DATA (file), \
632 XSTRING_DATA (newer)); \ 684 XSTRING_DATA (newer)); \
633 else if (source_only) \ 685 else if (source_only) \
634 message ("Loading %s..." done " (file %s.elc does not exist)", \ 686 message ("Loading %s..." done " (file %s.elc does not exist)", \
635 XSTRING_DATA (file), \ 687 XSTRING_DATA (file), \
636 XSTRING_DATA (Ffile_name_nondirectory (file))); \ 688 XSTRING_DATA (Ffile_name_nondirectory (file))); \
637 else if (message_p) \ 689 else if (message_p) \
638 message ("Loading %s..." done, XSTRING_DATA (file)); \ 690 message ("Loading %s..." done, XSTRING_DATA (file)); \
639 } while (0) 691 } while (0)
640 692
641 PRINT_LOADING_MESSAGE (""); 693 PRINT_LOADING_MESSAGE ("");
642 694
643 { 695 {
650 lispstream = make_filedesc_input_stream (fd, 0, -1, LSTR_CLOSING); 702 lispstream = make_filedesc_input_stream (fd, 0, -1, LSTR_CLOSING);
651 /* 64K is used for normal files; 8K should be OK here because Lisp 703 /* 64K is used for normal files; 8K should be OK here because Lisp
652 files aren't really all that big. */ 704 files aren't really all that big. */
653 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED, 705 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED,
654 block_size); 706 block_size);
707 #ifdef MULE
708 lispstream = make_decoding_input_stream
709 (XLSTREAM (lispstream), Fget_coding_system (codesys));
710 Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED,
711 block_size);
712 #endif /* MULE */
655 713
656 /* NOTE: Order of these is very important. Don't rearrange them. */ 714 /* NOTE: Order of these is very important. Don't rearrange them. */
657 record_unwind_protect (load_unwind, lispstream); 715 record_unwind_protect (load_unwind, lispstream);
658 record_unwind_protect (load_descriptor_unwind, Vload_descriptor_list); 716 record_unwind_protect (load_descriptor_unwind, Vload_descriptor_list);
659 record_unwind_protect (load_file_name_internal_unwind, 717 record_unwind_protect (load_file_name_internal_unwind,
670 #ifdef I18N3 728 #ifdef I18N3
671 record_unwind_protect (restore_file_domain, Vfile_domain); 729 record_unwind_protect (restore_file_domain, Vfile_domain);
672 Vfile_domain = Qnil; /* set it to nil; a call to #'domain will set it. */ 730 Vfile_domain = Qnil; /* set it to nil; a call to #'domain will set it. */
673 #endif 731 #endif
674 load_in_progress++; 732 load_in_progress++;
733
734 /* Now determine what sort of ELC file we're reading in. */
735 record_unwind_protect (load_byte_code_version_unwind,
736 make_int (load_byte_code_version));
737 if (reading_elc)
738 {
739 char elc_header[8];
740 int num_read;
741
742 num_read = Lstream_read (XLSTREAM (lispstream), elc_header, 8);
743 if (num_read < 8
744 || strncmp (elc_header, ";ELC", 4))
745 {
746 /* Huh? Probably not a valid ELC file. */
747 load_byte_code_version = 100; /* no Ebolification needed */
748 Lstream_unread (XLSTREAM (lispstream), elc_header, num_read);
749 }
750 else
751 load_byte_code_version = elc_header[4];
752 }
753 else
754 load_byte_code_version = 100; /* no Ebolification needed */
755
675 readevalloop (lispstream, file, Feval, 0); 756 readevalloop (lispstream, file, Feval, 0);
757 #ifdef MULE
758 if (!NILP (used_codesys))
759 Fset (used_codesys,
760 XCODING_SYSTEM_NAME
761 (decoding_stream_coding_system (XLSTREAM (lispstream))));
762 #endif /* MULE */
676 unbind_to (speccount, Qnil); 763 unbind_to (speccount, Qnil);
677 764
678 NUNGCPRO; 765 NUNGCPRO;
679 } 766 }
680 767
699 if (purify_flag && noninteractive) 786 if (purify_flag && noninteractive)
700 { 787 {
701 if (EQ (last_file_loaded, file)) 788 if (EQ (last_file_loaded, file))
702 message_append (" (%d)", purespace_usage() - pure_usage); 789 message_append (" (%d)", purespace_usage() - pure_usage);
703 else 790 else
704 message ("Loading %s ...done (%d)", XSTRING_DATA (file), 791 message ("Loading %s...done (%d)", XSTRING_DATA (file),
705 purespace_usage() - pure_usage); 792 purespace_usage() - pure_usage);
706 } 793 }
707 #endif 794 #endif /* DEBUG_XEMACS */
708 795
709 if (!noninteractive) 796 if (!noninteractive)
710 PRINT_LOADING_MESSAGE ("done"); 797 PRINT_LOADING_MESSAGE ("done");
711 798
712 UNGCPRO; 799 UNGCPRO;
713 return Qt; 800 return Qt;
714 } 801 }
715 802
716 803
1075 1162
1076 `locate-file' will primarily get confused if you add a file that shadows 1163 `locate-file' will primarily get confused if you add a file that shadows
1077 (i.e. has the same name as) another file further down in the directory list. 1164 (i.e. has the same name as) another file further down in the directory list.
1078 In this case, you must call `locate-file-clear-hashing'. 1165 In this case, you must call `locate-file-clear-hashing'.
1079 */ 1166 */
1080 (path)) 1167 (path))
1081 { 1168 {
1082 Lisp_Object pathtail; 1169 Lisp_Object pathtail;
1083 1170
1084 for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail)) 1171 for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail))
1085 { 1172 {
1583 } 1670 }
1584 } 1671 }
1585 return i; 1672 return i;
1586 } 1673 }
1587 1674
1675 #ifdef MULE
1676 /* #### need some way of reading an extended character with
1677 an escape sequence. */
1678 #endif
1588 1679
1589 default: 1680 default:
1590 return c; 1681 return c;
1591 } 1682 }
1592 } 1683 }
1650 if (! (saw_a_backslash || uninterned_symbol)) 1741 if (! (saw_a_backslash || uninterned_symbol))
1651 { 1742 {
1652 /* If a token had any backslashes in it, it is disqualified from 1743 /* If a token had any backslashes in it, it is disqualified from
1653 being an integer or a float. This means that 123\456 is a 1744 being an integer or a float. This means that 123\456 is a
1654 symbol, as is \123 (which is the way (intern "123") prints). 1745 symbol, as is \123 (which is the way (intern "123") prints).
1655 Also, if token was preceded by #:, it's always a symbol. 1746 Also, if token was preceeded by #:, it's always a symbol.
1656 */ 1747 */
1657 char *p = read_ptr + len; 1748 char *p = read_ptr + len;
1658 char *p1 = read_ptr; 1749 char *p1 = read_ptr;
1659 1750
1660 if (*p1 == '+' || *p1 == '-') p1++; 1751 if (*p1 == '+' || *p1 == '-') p1++;
1741 } 1832 }
1742 1833
1743 if (p == lim) 1834 if (p == lim)
1744 goto loser; 1835 goto loser;
1745 1836
1746 for (; (p < lim) && (*p != '\0'); p++) 1837 for (; p < lim; p++)
1747 { 1838 {
1748 int c = *p; 1839 int c = *p;
1749 unsigned EMACS_INT onum; 1840 unsigned EMACS_INT onum;
1750 1841
1751 if (isdigit (c)) 1842 if (isdigit (c))
2270 { 2361 {
2271 unreadchar (readcharfun, c); 2362 unreadchar (readcharfun, c);
2272 return Fsignal (Qinvalid_read_syntax, 2363 return Fsignal (Qinvalid_read_syntax,
2273 list1 (build_string ("Cannot read unreadable object"))); 2364 list1 (build_string ("Cannot read unreadable object")));
2274 } 2365 }
2275 #ifdef FEATUREP_SYNTAX
2276 case '+':
2277 case '-':
2278 {
2279 Lisp_Object fexp, obj, tem;
2280 struct gcpro gcpro1, gcpro2;
2281
2282 fexp = read0(readcharfun);
2283 obj = read0(readcharfun);
2284
2285 /* the call to `featurep' may GC. */
2286 GCPRO2(fexp, obj);
2287 tem = call1(Qfeaturep, fexp);
2288 UNGCPRO;
2289
2290 if (c == '+' && NILP(tem)) goto retry;
2291 if (c == '-' && !NILP(tem)) goto retry;
2292 return obj;
2293 }
2294 #endif
2295 2366
2296 default: 2367 default:
2297 { 2368 {
2298 unreadchar (readcharfun, c); 2369 unreadchar (readcharfun, c);
2299 return Fsignal (Qinvalid_read_syntax, 2370 return Fsignal (Qinvalid_read_syntax,
2504 2575
2505 if (ch == terminator) 2576 if (ch == terminator)
2506 return (state); 2577 return (state);
2507 else 2578 else
2508 unreadchar (readcharfun, ch); 2579 unreadchar (readcharfun, ch);
2509 #ifdef FEATUREP_SYNTAX
2510 if (ch == ']') 2580 if (ch == ']')
2511 syntax_error ("\"]\" in a list"); 2581 syntax_error ("\"]\" in a list");
2512 else if (ch == ')') 2582 else if (ch == ')')
2513 syntax_error ("\")\" in a vector"); 2583 syntax_error ("\")\" in a vector");
2514 #endif
2515 state = ((conser) (readcharfun, state, len)); 2584 state = ((conser) (readcharfun, state, len));
2516 } 2585 }
2517 } 2586 }
2518 2587
2519 2588
2541 2610
2542 elt = XCDR (elt); 2611 elt = XCDR (elt);
2543 free_cons (XCONS (tem)); 2612 free_cons (XCONS (tem));
2544 tem = Qnil; 2613 tem = Qnil;
2545 ch = XCHAR (elt); 2614 ch = XCHAR (elt);
2546 #ifdef FEATUREP_SYNTAX
2547 if (ch == s->terminator) /* deal with #+, #- reader macros */
2548 {
2549 unreadchar (readcharfun, s->terminator);
2550 goto done;
2551 }
2552 else if (ch == ']')
2553 syntax_error ("']' in a list");
2554 else if (ch == ')')
2555 syntax_error ("')' in a vector");
2556 else
2557 #endif
2558 if (ch != '.') 2615 if (ch != '.')
2559 signal_simple_error ("BUG! Internal reader error", elt); 2616 signal_simple_error ("BUG! Internal reader error", elt);
2560 else if (!s->allow_dotted_lists) 2617 else if (!s->allow_dotted_lists)
2561 syntax_error ("\".\" in a vector"); 2618 syntax_error ("\".\" in a vector");
2562 else 2619 else
2677 { 2734 {
2678 if (purify_flag) 2735 if (purify_flag)
2679 { 2736 {
2680 if (NILP (Vdoc_file_name)) 2737 if (NILP (Vdoc_file_name))
2681 /* We have not yet called Snarf-documentation, so 2738 /* We have not yet called Snarf-documentation, so
2682 assume this file is described in the DOC file 2739 assume this file is described in the DOC-MM.NN
2683 and Snarf-documentation will fill in the right 2740 file and Snarf-documentation will fill in the
2684 value later. For now, replace the whole list 2741 right value later. For now, replace the whole
2685 with 0. */ 2742 list with 0. */
2686 XCAR (holding_cons) = Qzero; 2743 XCAR (holding_cons) = Qzero;
2687 else 2744 else
2688 /* We have already called Snarf-documentation, so 2745 /* We have already called Snarf-documentation, so
2689 make a relative file name for this file, so it 2746 make a relative file name for this file, so it
2690 can be found properly in the installed Lisp 2747 can be found properly in the installed Lisp
2810 free_cons (victim); 2867 free_cons (victim);
2811 } 2868 }
2812 GCPRO1 (make_byte_code_args[0]); 2869 GCPRO1 (make_byte_code_args[0]);
2813 gcpro1.nvars = len; 2870 gcpro1.nvars = len;
2814 2871
2872 /* v18 or v19 bytecode file. Need to Ebolify. */
2873 if (load_byte_code_version < 20 && VECTORP (make_byte_code_args[2]))
2874 ebolify_bytecode_constants (make_byte_code_args[2]);
2875
2815 /* make-byte-code looks at purify_flag, which should have the same 2876 /* make-byte-code looks at purify_flag, which should have the same
2816 * value as our "read-pure" argument */ 2877 * value as our "read-pure" argument */
2817 stuff = Fmake_byte_code (len, make_byte_code_args); 2878 stuff = Fmake_byte_code (len, make_byte_code_args);
2879 XCOMPILED_FUNCTION (stuff)->flags.ebolified = (load_byte_code_version < 20);
2818 if (saw_a_doc_ref) 2880 if (saw_a_doc_ref)
2819 Vload_force_doc_string_list = Fcons (stuff, Vload_force_doc_string_list); 2881 Vload_force_doc_string_list = Fcons (stuff, Vload_force_doc_string_list);
2820 UNGCPRO; 2882 UNGCPRO;
2821 return stuff; 2883 return stuff;
2822 } 2884 }
3060 #endif 3122 #endif
3061 3123
3062 /* So that early-early stuff will work */ 3124 /* So that early-early stuff will work */
3063 Ffset (Qload, intern ("load-internal")); 3125 Ffset (Qload, intern ("load-internal"));
3064 3126
3065 #ifdef FEATUREP_SYNTAX
3066 Qfeaturep = intern("featurep");
3067 staticpro(&Qfeaturep);
3068 Fprovide(intern("xemacs"));
3069 #endif
3070 #ifdef LISP_BACKQUOTES 3127 #ifdef LISP_BACKQUOTES
3071 old_backquote_flag = new_backquote_flag = 0; 3128 old_backquote_flag = new_backquote_flag = 0;
3072 #endif 3129 #endif
3073 3130
3074 #ifdef I18N3 3131 #ifdef I18N3