Now on revision 108837. ------------------------------------------------------------ revno: 108837 committer: Chong Yidong branch nick: trunk timestamp: Tue 2012-07-03 13:28:42 +0800 message: * xml.el: Protect parser against XML bombs. (xml-entity-expansion-limit): New variable. (xml-parse-string, xml-substitute-special): Use it. (xml-parse-dtd): Avoid infloop if the DTD is not terminated. * test/automated/xml-parse-tests.el: Update testcases. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-03 02:16:11 +0000 +++ lisp/ChangeLog 2012-07-03 05:28:42 +0000 @@ -1,3 +1,10 @@ +2012-07-03 Chong Yidong + + * xml.el: Protect parser against XML bombs. + (xml-entity-expansion-limit): New variable. + (xml-parse-string, xml-substitute-special): Use it. + (xml-parse-dtd): Avoid infloop if the DTD is not terminated. + 2012-07-03 Glenn Morris * progmodes/bug-reference.el (bug-reference-bug-regexp): === modified file 'lisp/xml.el' --- lisp/xml.el 2012-07-02 16:21:54 +0000 +++ lisp/xml.el 2012-07-03 05:28:42 +0000 @@ -98,6 +98,13 @@ ("amp" . "&")) "Alist mapping XML entities to their replacement text.") +(defvar xml-entity-expansion-limit 20000 + "The maximum size of entity reference expansions. +If the size of the buffer increases by this many characters while +expanding entity references in a segment of character data, the +XML parser signals an error. Setting this to nil removes the +limit (making the parser vulnerable to XML bombs).") + (defvar xml-parameter-entity-alist nil "Alist of defined XML parametric entities.") @@ -471,7 +478,7 @@ (while (not (looking-at end)) (cond ((eobp) - (error "XML: (Not Well-Formed) End of buffer while reading element `%s'" + (error "XML: (Not Well-Formed) End of document while reading element `%s'" node-name)) ((looking-at " (- (buffer-size) (point)) + (+ old-remaining-size xml-entity-expansion-limit)) + (error "XML: Entity reference expansion \ +surpassed `xml-entity-expansion-limit'")))) ;; [2.11] Clean up line breaks. (let ((end-marker (point-marker))) (goto-char start) @@ -689,6 +704,8 @@ (while (not (looking-at "\\s-*\\]")) (skip-syntax-forward " ") (cond + ((eobp) + (error "XML: (Well-Formed) End of document while reading DTD")) ;; Element declaration [45]: ((and (looking-at (eval-when-compile (concat "") (goto-char (match-end 0)))) @@ -876,6 +895,7 @@ (let ((ref-re (eval-when-compile (concat "&\\(?:#\\(x\\)?\\([0-9]+\\)\\|\\(" xml-name-re "\\)\\);"))) + (strlen (length string)) children) (while (string-match ref-re string) (push (substring string 0 (match-beginning 0)) children) @@ -891,7 +911,8 @@ (error "XML: (Validity) Undefined character `x%s'" ref)) (t xml-undefined-entity)) children) - (setq string remainder)) + (setq string remainder + strlen (length string))) ;; [4.4.5] Entity references are "included in literal". ;; Note that we don't need do anything special to treat ;; quotes as normal data characters. @@ -900,7 +921,11 @@ (if xml-validating-parser (error "XML: (Validity) Undefined entity `%s'" ref) xml-undefined-entity)))) - (setq string (concat val remainder)))))) + (setq string (concat val remainder))) + (and xml-entity-expansion-limit + (> (length string) (+ strlen xml-entity-expansion-limit)) + (error "XML: Passed `xml-entity-expansion-limit' while expanding `&%s;'" + ref))))) (mapconcat 'identity (nreverse (cons string children)) ""))) (defun xml-substitute-numeric-entities (string) === modified file 'test/ChangeLog' --- test/ChangeLog 2012-07-02 16:21:54 +0000 +++ test/ChangeLog 2012-07-03 05:28:42 +0000 @@ -1,3 +1,7 @@ +2012-07-03 Chong Yidong + + * automated/xml-parse-tests.el (xml-parse-tests--bad-data): New. + 2012-07-02 Chong Yidong * automated/xml-parse-tests.el (xml-parse-tests--data): More === modified file 'test/automated/xml-parse-tests.el' --- test/automated/xml-parse-tests.el 2012-07-02 16:21:54 +0000 +++ test/automated/xml-parse-tests.el 2012-07-03 05:28:42 +0000 @@ -55,14 +55,29 @@ ("&amp;" . ((foo () "&")))) "Alist of XML strings and their expected parse trees.") +(defvar xml-parse-tests--bad-data + '(;; XML bomb in content + "]>&lol2;" + ;; XML bomb in attribute value + "]>!" + ;; Non-terminating DTD + "" + "asdf" + "asdf&abc;") + "List of XML strings that should signal an error in the parser") + (ert-deftest xml-parse-tests () "Test XML parsing." (with-temp-buffer (dolist (test xml-parse-tests--data) (erase-buffer) (insert (car test)) - (should (equal (cdr test) - (xml-parse-region (point-min) (point-max))))))) + (should (equal (cdr test) (xml-parse-region)))) + (let ((xml-entity-expansion-limit 50)) + (dolist (test xml-parse-tests--bad-data) + (erase-buffer) + (insert test) + (should-error (xml-parse-region)))))) ;; Local Variables: ;; no-byte-compile: t ------------------------------------------------------------ revno: 108836 committer: Dmitry Antipov branch nick: trunk timestamp: Tue 2012-07-03 07:57:52 +0400 message: Cleanup basic buffer management. * buffer.h (struct buffer): Change layout to use generic vector marking code. Fix some comments. Change type of 'clip_changed' to bitfield. Remove unused #ifndef old. (FIRST_FIELD_PER_BUFFER, LAST_FIELD_PER_BUFFER): Remove. (GET_OVERLAYS_AT): Fix indentation. (for_each_per_buffer_object_at): New macro. * buffer.c (clone_per_buffer_values, reset_buffer_local_variables) (Fbuffer_local_variables): Use it. (init_buffer_once, syms_of_buffer): Remove unused #ifndef old. * alloc.c (allocate_buffer): Adjust to match new layout of struct buffer. Fix comment. (mark_overlay): New function. (mark_buffer): Use it. Use mark_vectorlike to mark normal Lisp area of struct buffer. (mark_object): Use it. Adjust marking of misc objects and related comments. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-02 10:08:41 +0000 +++ src/ChangeLog 2012-07-03 03:57:52 +0000 @@ -1,3 +1,23 @@ +2012-07-03 Dmitry Antipov + + Cleanup basic buffer management. + * buffer.h (struct buffer): Change layout to use generic vector + marking code. Fix some comments. Change type of 'clip_changed' + to bitfield. Remove unused #ifndef old. + (FIRST_FIELD_PER_BUFFER, LAST_FIELD_PER_BUFFER): Remove. + (GET_OVERLAYS_AT): Fix indentation. + (for_each_per_buffer_object_at): New macro. + * buffer.c (clone_per_buffer_values, reset_buffer_local_variables) + (Fbuffer_local_variables): Use it. + (init_buffer_once, syms_of_buffer): Remove unused #ifndef old. + * alloc.c (allocate_buffer): Adjust to match new layout of + struct buffer. Fix comment. + (mark_overlay): New function. + (mark_buffer): Use it. Use mark_vectorlike to mark normal + Lisp area of struct buffer. + (mark_object): Use it. Adjust marking of misc objects + and related comments. + 2012-07-02 Paul Eggert * alloc.c (mark_object): Remove "#ifdef GC_CHECK_MARKED_OBJECTS" === modified file 'src/alloc.c' --- src/alloc.c 2012-07-02 07:36:17 +0000 +++ src/alloc.c 2012-07-03 03:57:52 +0000 @@ -1186,21 +1186,6 @@ MALLOC_UNBLOCK_INPUT; } -/* Return a new buffer structure allocated from the heap with - a call to lisp_malloc. */ - -struct buffer * -allocate_buffer (void) -{ - struct buffer *b - = (struct buffer *) lisp_malloc (sizeof (struct buffer), - MEM_TYPE_BUFFER); - XSETPVECTYPESIZE (b, PVEC_BUFFER, - ((sizeof (struct buffer) + sizeof (EMACS_INT) - 1) - / sizeof (EMACS_INT))); - return b; -} - #ifndef SYSTEM_MALLOC @@ -3258,6 +3243,17 @@ return v; } +struct buffer * +allocate_buffer (void) +{ + struct buffer *b = lisp_malloc (sizeof (struct buffer), MEM_TYPE_BUFFER); + + XSETPVECTYPESIZE (b, PVEC_BUFFER, (offsetof (struct buffer, own_text) + - header_size) / word_size); + /* Note that the fields of B are not initialized. */ + return b; +} + struct Lisp_Hash_Table * allocate_hash_table (void) { @@ -5786,15 +5782,29 @@ } } -/* Mark the pointers in a buffer structure. */ +/* Mark the chain of overlays starting at PTR. */ + +static void +mark_overlay (struct Lisp_Overlay *ptr) +{ + for (; ptr && !ptr->gcmarkbit; ptr = ptr->next) + { + ptr->gcmarkbit = 1; + mark_object (ptr->start); + mark_object (ptr->end); + mark_object (ptr->plist); + } +} + +/* Mark Lisp_Objects and special pointers in BUFFER. */ static void mark_buffer (struct buffer *buffer) { - register Lisp_Object *ptr, tmp; + /* This is handled much like other pseudovectors... */ + mark_vectorlike ((struct Lisp_Vector *) buffer); - eassert (!VECTOR_MARKED_P (buffer)); - VECTOR_MARK (buffer); + /* ...but there are some buffer-specific things. */ MARK_INTERVAL_TREE (BUF_INTERVALS (buffer)); @@ -5802,24 +5812,8 @@ a special way just before the sweep phase, and after stripping some of its elements that are not needed any more. */ - if (buffer->overlays_before) - { - XSETMISC (tmp, buffer->overlays_before); - mark_object (tmp); - } - if (buffer->overlays_after) - { - XSETMISC (tmp, buffer->overlays_after); - mark_object (tmp); - } - - /* buffer-local Lisp variables start at `undo_list', - tho only the ones from `name' on are GC'd normally. */ - for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name); - ptr <= &PER_BUFFER_VALUE (buffer, - PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER)); - ptr++) - mark_object (*ptr); + mark_overlay (buffer->overlays_before); + mark_overlay (buffer->overlays_after); /* If this is an indirect buffer, mark its base buffer. */ if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer)) @@ -6061,52 +6055,35 @@ case Lisp_Misc: CHECK_ALLOCATED_AND_LIVE (live_misc_p); - if (XMISCANY (obj)->gcmarkbit) - break; - XMISCANY (obj)->gcmarkbit = 1; - switch (XMISCTYPE (obj)) + if (XMISCTYPE (obj) == Lisp_Misc_Overlay) + mark_overlay (XOVERLAY (obj)); + else { - - case Lisp_Misc_Marker: - /* DO NOT mark thru the marker's chain. - The buffer's markers chain does not preserve markers from gc; - instead, markers are removed from the chain when freed by gc. */ - break; - - case Lisp_Misc_Save_Value: + if (XMISCANY (obj)->gcmarkbit) + break; + XMISCANY (obj)->gcmarkbit = 1; + + /* Note that we don't mark thru the marker's + chain. The buffer's markers chain does not + preserve markers from GC; instead, markers + are removed from the chain when freed by GC. */ + #if GC_MARK_STACK - { - register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj); - /* If DOGC is set, POINTER is the address of a memory - area containing INTEGER potential Lisp_Objects. */ - if (ptr->dogc) - { - Lisp_Object *p = (Lisp_Object *) ptr->pointer; - ptrdiff_t nelt; - for (nelt = ptr->integer; nelt > 0; nelt--, p++) - mark_maybe_object (*p); - } - } + if (XMISCTYPE (obj) == Lisp_Misc_Save_Value) + { + register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj); + /* If DOGC is set, POINTER is the address of a memory + area containing INTEGER potential Lisp_Objects. */ + if (ptr->dogc) + { + Lisp_Object *p = (Lisp_Object *) ptr->pointer; + ptrdiff_t nelt; + for (nelt = ptr->integer; nelt > 0; nelt--, p++) + mark_maybe_object (*p); + } + } #endif - break; - - case Lisp_Misc_Overlay: - { - struct Lisp_Overlay *ptr = XOVERLAY (obj); - mark_object (ptr->start); - mark_object (ptr->end); - mark_object (ptr->plist); - if (ptr->next) - { - XSETMISC (obj, ptr->next); - goto loop; - } - } - break; - - default: - abort (); } break; === modified file 'src/buffer.c' --- src/buffer.c 2012-06-22 21:17:42 +0000 +++ src/buffer.c 2012-07-03 03:57:52 +0000 @@ -465,11 +465,7 @@ XSETBUFFER (to_buffer, to); - /* buffer-local Lisp variables start at `undo_list', - tho only the ones from `name' on are GC'd normally. */ - for (offset = PER_BUFFER_VAR_OFFSET (FIRST_FIELD_PER_BUFFER); - offset <= PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER); - offset += sizeof (Lisp_Object)) + for_each_per_buffer_object_at (offset) { Lisp_Object obj; @@ -820,14 +816,8 @@ if (permanent_too || buffer_permanent_local_flags[i] == 0) SET_PER_BUFFER_VALUE_P (b, i, 0); - /* For each slot that has a default value, - copy that into the slot. */ - - /* buffer-local Lisp variables start at `undo_list', - tho only the ones from `name' on are GC'd normally. */ - for (offset = PER_BUFFER_VAR_OFFSET (FIRST_FIELD_PER_BUFFER); - offset <= PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER); - offset += sizeof (Lisp_Object)) + /* For each slot that has a default value, copy that into the slot. */ + for_each_per_buffer_object_at (offset) { int idx = PER_BUFFER_IDX (offset); if ((idx > 0 @@ -1063,12 +1053,7 @@ { int offset, idx; - /* buffer-local Lisp variables start at `undo_list', - tho only the ones from `name' on are GC'd normally. */ - for (offset = PER_BUFFER_VAR_OFFSET (FIRST_FIELD_PER_BUFFER); - offset <= PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER); - /* sizeof EMACS_INT == sizeof Lisp_Object */ - offset += (sizeof (EMACS_INT))) + for_each_per_buffer_object_at (offset) { idx = PER_BUFFER_IDX (offset); if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) @@ -4903,9 +4888,7 @@ BVAR (&buffer_defaults, case_fold_search) = Qt; BVAR (&buffer_defaults, auto_fill_function) = Qnil; BVAR (&buffer_defaults, selective_display) = Qnil; -#ifndef old BVAR (&buffer_defaults, selective_display_ellipses) = Qt; -#endif BVAR (&buffer_defaults, abbrev_table) = Qnil; BVAR (&buffer_defaults, display_table) = Qnil; BVAR (&buffer_defaults, undo_list) = Qnil; @@ -4984,9 +4967,7 @@ XSETFASTINT (BVAR (&buffer_local_flags, case_fold_search), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, auto_fill_function), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx; -#ifndef old XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx; -#endif XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx; @@ -5594,12 +5575,10 @@ all the rest of the line invisible; also, when saving the buffer in a file, save the ^M as a newline. */); -#ifndef old DEFVAR_PER_BUFFER ("selective-display-ellipses", &BVAR (current_buffer, selective_display_ellipses), Qnil, doc: /* Non-nil means display ... on previous line when a line is invisible. */); -#endif DEFVAR_PER_BUFFER ("overwrite-mode", &BVAR (current_buffer, overwrite_mode), Qnil, doc: /* Non-nil if self-insertion should replace existing text. === modified file 'src/buffer.h' --- src/buffer.h 2012-06-24 17:39:14 +0000 +++ src/buffer.h 2012-07-03 03:57:52 +0000 @@ -482,142 +482,26 @@ struct buffer { - /* Everything before the `name' slot must be of a non-Lisp_Object type, - and every slot after `name' must be a Lisp_Object. - - Check out mark_buffer (alloc.c) to see why. */ - - /* HEADER.NEXT is the next buffer, in chain of all buffers, - including killed buffers. - This chain is used only for garbage collection, in order to - collect killed buffers properly. - Note that vectors and most pseudovectors are all on one chain, - but buffers are on a separate chain of their own. */ + /* HEADER.NEXT is the next buffer, in chain of all buffers, including killed + buffers. This chain, starting from all_buffers, is used only for garbage + collection, in order to collect killed buffers properly. Note that large + vectors and large pseudo-vector objects are all on another chain starting + from large_vectors. */ struct vectorlike_header header; - /* This structure holds the coordinates of the buffer contents - in ordinary buffers. In indirect buffers, this is not used. */ - struct buffer_text own_text; - - /* This points to the `struct buffer_text' that used for this buffer. - In an ordinary buffer, this is the own_text field above. - In an indirect buffer, this is the own_text field of another buffer. */ - struct buffer_text *text; - - /* Char position of point in buffer. */ - ptrdiff_t pt; - /* Byte position of point in buffer. */ - ptrdiff_t pt_byte; - /* Char position of beginning of accessible range. */ - ptrdiff_t begv; - /* Byte position of beginning of accessible range. */ - ptrdiff_t begv_byte; - /* Char position of end of accessible range. */ - ptrdiff_t zv; - /* Byte position of end of accessible range. */ - ptrdiff_t zv_byte; - - /* In an indirect buffer, this points to the base buffer. - In an ordinary buffer, it is 0. */ - struct buffer *base_buffer; - - /* A non-zero value in slot IDX means that per-buffer variable - with index IDX has a local value in this buffer. The index IDX - for a buffer-local variable is stored in that variable's slot - in buffer_local_flags as a Lisp integer. If the index is -1, - this means the variable is always local in all buffers. */ -#define MAX_PER_BUFFER_VARS 50 - char local_flags[MAX_PER_BUFFER_VARS]; - - /* Set to the modtime of the visited file when read or written. - EMACS_NSECS (modtime) == NONEXISTENT_MODTIME_NSECS means - visited file was nonexistent. EMACS_NSECS (modtime) == - UNKNOWN_MODTIME_NSECS means visited file modtime unknown; - in no case complain about any mismatch on next save attempt. */ -#define NONEXISTENT_MODTIME_NSECS (-1) -#define UNKNOWN_MODTIME_NSECS (-2) - EMACS_TIME modtime; - /* Size of the file when modtime was set. This is used to detect the - case where the file grew while we were reading it, so the modtime - is still the same (since it's rounded up to seconds) but we're actually - not up-to-date. -1 means the size is unknown. Only meaningful if - modtime is actually set. */ - off_t modtime_size; - /* The value of text->modiff at the last auto-save. */ - EMACS_INT auto_save_modified; - /* The value of text->modiff at the last display error. - Redisplay of this buffer is inhibited until it changes again. */ - EMACS_INT display_error_modiff; - /* The time at which we detected a failure to auto-save, - Or 0 if we didn't have a failure. */ - time_t auto_save_failure_time; - /* Position in buffer at which display started - the last time this buffer was displayed. */ - ptrdiff_t last_window_start; - - /* Set nonzero whenever the narrowing is changed in this buffer. */ - int clip_changed; - - /* If the long line scan cache is enabled (i.e. the buffer-local - variable cache-long-line-scans is non-nil), newline_cache - points to the newline cache, and width_run_cache points to the - width run cache. - - The newline cache records which stretches of the buffer are - known *not* to contain newlines, so that they can be skipped - quickly when we search for newlines. - - The width run cache records which stretches of the buffer are - known to contain characters whose widths are all the same. If - the width run cache maps a character to a value > 0, that value is - the character's width; if it maps a character to zero, we don't - know what its width is. This allows compute_motion to process - such regions very quickly, using algebra instead of inspecting - each character. See also width_table, below. */ - struct region_cache *newline_cache; - struct region_cache *width_run_cache; - - /* Non-zero means don't use redisplay optimizations for - displaying this buffer. */ - unsigned prevent_redisplay_optimizations_p : 1; - - /* List of overlays that end at or before the current center, - in order of end-position. */ - struct Lisp_Overlay *overlays_before; - - /* List of overlays that end after the current center, - in order of start-position. */ - struct Lisp_Overlay *overlays_after; - - /* Position where the overlay lists are centered. */ - ptrdiff_t overlay_center; - - /* Everything from here down must be a Lisp_Object. */ - /* buffer-local Lisp variables start at `undo_list', - tho only the ones from `name' on are GC'd normally. */ - #define FIRST_FIELD_PER_BUFFER undo_list - - /* Changes in the buffer are recorded here for undo. - t means don't record anything. - This information belongs to the base buffer of an indirect buffer, - But we can't store it in the struct buffer_text - because local variables have to be right in the struct buffer. - So we copy it around in set_buffer_internal. - This comes before `name' because it is marked in a special way. */ - Lisp_Object BUFFER_INTERNAL_FIELD (undo_list); - /* The name of this buffer. */ Lisp_Object BUFFER_INTERNAL_FIELD (name); /* The name of the file visited in this buffer, or nil. */ Lisp_Object BUFFER_INTERNAL_FIELD (filename); - /* Dir for expanding relative file names. */ + + /* Directory for expanding relative file names. */ Lisp_Object BUFFER_INTERNAL_FIELD (directory); - /* True if this buffer has been backed up (if you write to the - visited file and it hasn't been backed up, then a backup will - be made). */ - /* This isn't really used by the C code, so could be deleted. */ + + /* True if this buffer has been backed up (if you write to the visited + file and it hasn't been backed up, then a backup will be made). */ Lisp_Object BUFFER_INTERNAL_FIELD (backed_up); + /* Length of file when last read or saved. -1 means auto saving turned off because buffer shrank a lot. -2 means don't turn off auto saving if buffer shrinks. @@ -625,6 +509,7 @@ This is not in the struct buffer_text because it's not used in indirect buffers at all. */ Lisp_Object BUFFER_INTERNAL_FIELD (save_length); + /* File name used for auto-saving this buffer. This is not in the struct buffer_text because it's not used in indirect buffers at all. */ @@ -632,6 +517,7 @@ /* Non-nil if buffer read-only. */ Lisp_Object BUFFER_INTERNAL_FIELD (read_only); + /* "The mark". This is a marker which may point into this buffer or may point nowhere. */ Lisp_Object BUFFER_INTERNAL_FIELD (mark); @@ -641,10 +527,12 @@ symbols, just the symbol appears as the element. */ Lisp_Object BUFFER_INTERNAL_FIELD (local_var_alist); - /* Symbol naming major mode (eg, lisp-mode). */ + /* Symbol naming major mode (e.g., lisp-mode). */ Lisp_Object BUFFER_INTERNAL_FIELD (major_mode); - /* Pretty name of major mode (eg, "Lisp"). */ + + /* Pretty name of major mode (e.g., "Lisp"). */ Lisp_Object BUFFER_INTERNAL_FIELD (mode_name); + /* Mode line element that controls format of mode line. */ Lisp_Object BUFFER_INTERNAL_FIELD (mode_line_format); @@ -654,10 +542,13 @@ /* Keys that are bound local to this buffer. */ Lisp_Object BUFFER_INTERNAL_FIELD (keymap); + /* This buffer's local abbrev table. */ Lisp_Object BUFFER_INTERNAL_FIELD (abbrev_table); + /* This buffer's syntax table. */ Lisp_Object BUFFER_INTERNAL_FIELD (syntax_table); + /* This buffer's category table. */ Lisp_Object BUFFER_INTERNAL_FIELD (category_table); @@ -668,48 +559,61 @@ Lisp_Object BUFFER_INTERNAL_FIELD (tab_width); Lisp_Object BUFFER_INTERNAL_FIELD (fill_column); Lisp_Object BUFFER_INTERNAL_FIELD (left_margin); + /* Function to call when insert space past fill column. */ Lisp_Object BUFFER_INTERNAL_FIELD (auto_fill_function); /* Case table for case-conversion in this buffer. This char-table maps each char into its lower-case version. */ Lisp_Object BUFFER_INTERNAL_FIELD (downcase_table); + /* Char-table mapping each char to its upper-case version. */ Lisp_Object BUFFER_INTERNAL_FIELD (upcase_table); + /* Char-table for conversion for case-folding search. */ Lisp_Object BUFFER_INTERNAL_FIELD (case_canon_table); + /* Char-table of equivalences for case-folding search. */ Lisp_Object BUFFER_INTERNAL_FIELD (case_eqv_table); /* Non-nil means do not display continuation lines. */ Lisp_Object BUFFER_INTERNAL_FIELD (truncate_lines); + /* Non-nil means to use word wrapping when displaying continuation lines. */ Lisp_Object BUFFER_INTERNAL_FIELD (word_wrap); + /* Non-nil means display ctl chars with uparrow. */ Lisp_Object BUFFER_INTERNAL_FIELD (ctl_arrow); + /* Non-nil means reorder bidirectional text for display in the visual order. */ Lisp_Object BUFFER_INTERNAL_FIELD (bidi_display_reordering); + /* If non-nil, specifies which direction of text to force in all the paragraphs of the buffer. Nil means determine paragraph direction dynamically for each paragraph. */ Lisp_Object BUFFER_INTERNAL_FIELD (bidi_paragraph_direction); + /* Non-nil means do selective display; see doc string in syms_of_buffer (buffer.c) for details. */ Lisp_Object BUFFER_INTERNAL_FIELD (selective_display); -#ifndef old + /* Non-nil means show ... at end of line followed by invisible lines. */ Lisp_Object BUFFER_INTERNAL_FIELD (selective_display_ellipses); -#endif + /* Alist of (FUNCTION . STRING) for each minor mode enabled in buffer. */ Lisp_Object BUFFER_INTERNAL_FIELD (minor_modes); + /* t if "self-insertion" should overwrite; `binary' if it should also overwrite newlines and tabs - for editing executables and the like. */ Lisp_Object BUFFER_INTERNAL_FIELD (overwrite_mode); - /* non-nil means abbrev mode is on. Expand abbrevs automatically. */ + + /* Non-nil means abbrev mode is on. Expand abbrevs automatically. */ Lisp_Object BUFFER_INTERNAL_FIELD (abbrev_mode); + /* Display table to use for text in this buffer. */ Lisp_Object BUFFER_INTERNAL_FIELD (display_table); + /* t means the mark and region are currently active. */ Lisp_Object BUFFER_INTERNAL_FIELD (mark_active); @@ -776,11 +680,13 @@ /* Widths of left and right marginal areas for windows displaying this buffer. */ - Lisp_Object BUFFER_INTERNAL_FIELD (left_margin_cols), BUFFER_INTERNAL_FIELD (right_margin_cols); + Lisp_Object BUFFER_INTERNAL_FIELD (left_margin_cols); + Lisp_Object BUFFER_INTERNAL_FIELD (right_margin_cols); /* Widths of left and right fringe areas for windows displaying this buffer. */ - Lisp_Object BUFFER_INTERNAL_FIELD (left_fringe_width), BUFFER_INTERNAL_FIELD (right_fringe_width); + Lisp_Object BUFFER_INTERNAL_FIELD (left_fringe_width); + Lisp_Object BUFFER_INTERNAL_FIELD (right_fringe_width); /* Non-nil means fringes are drawn outside display margins; othersize draw them between margin areas and text. */ @@ -788,7 +694,8 @@ /* Width and type of scroll bar areas for windows displaying this buffer. */ - Lisp_Object BUFFER_INTERNAL_FIELD (scroll_bar_width), BUFFER_INTERNAL_FIELD (vertical_scroll_bar_type); + Lisp_Object BUFFER_INTERNAL_FIELD (scroll_bar_width); + Lisp_Object BUFFER_INTERNAL_FIELD (vertical_scroll_bar_type); /* Non-nil means indicate lines not displaying text (in a style like vi). */ @@ -826,13 +733,127 @@ in the display of this buffer. */ Lisp_Object BUFFER_INTERNAL_FIELD (extra_line_spacing); - /* *Cursor type to display in non-selected windows. + /* Cursor type to display in non-selected windows. t means to use hollow box cursor. See `cursor-type' for other values. */ Lisp_Object BUFFER_INTERNAL_FIELD (cursor_in_non_selected_windows); - /* This must be the last field in the above list. */ - #define LAST_FIELD_PER_BUFFER cursor_in_non_selected_windows + /* No more Lisp_Object beyond this point. Except undo_list, + which is handled specially in Fgarbage_collect . */ + + /* This structure holds the coordinates of the buffer contents + in ordinary buffers. In indirect buffers, this is not used. */ + struct buffer_text own_text; + + /* This points to the `struct buffer_text' that used for this buffer. + In an ordinary buffer, this is the own_text field above. + In an indirect buffer, this is the own_text field of another buffer. */ + struct buffer_text *text; + + /* Char position of point in buffer. */ + ptrdiff_t pt; + + /* Byte position of point in buffer. */ + ptrdiff_t pt_byte; + + /* Char position of beginning of accessible range. */ + ptrdiff_t begv; + + /* Byte position of beginning of accessible range. */ + ptrdiff_t begv_byte; + + /* Char position of end of accessible range. */ + ptrdiff_t zv; + + /* Byte position of end of accessible range. */ + ptrdiff_t zv_byte; + + /* In an indirect buffer, this points to the base buffer. + In an ordinary buffer, it is 0. */ + struct buffer *base_buffer; + + /* A non-zero value in slot IDX means that per-buffer variable + with index IDX has a local value in this buffer. The index IDX + for a buffer-local variable is stored in that variable's slot + in buffer_local_flags as a Lisp integer. If the index is -1, + this means the variable is always local in all buffers. */ +#define MAX_PER_BUFFER_VARS 50 + char local_flags[MAX_PER_BUFFER_VARS]; + + /* Set to the modtime of the visited file when read or written. + EMACS_NSECS (modtime) == NONEXISTENT_MODTIME_NSECS means + visited file was nonexistent. EMACS_NSECS (modtime) == + UNKNOWN_MODTIME_NSECS means visited file modtime unknown; + in no case complain about any mismatch on next save attempt. */ +#define NONEXISTENT_MODTIME_NSECS (-1) +#define UNKNOWN_MODTIME_NSECS (-2) + EMACS_TIME modtime; + + /* Size of the file when modtime was set. This is used to detect the + case where the file grew while we were reading it, so the modtime + is still the same (since it's rounded up to seconds) but we're actually + not up-to-date. -1 means the size is unknown. Only meaningful if + modtime is actually set. */ + off_t modtime_size; + + /* The value of text->modiff at the last auto-save. */ + EMACS_INT auto_save_modified; + + /* The value of text->modiff at the last display error. + Redisplay of this buffer is inhibited until it changes again. */ + EMACS_INT display_error_modiff; + + /* The time at which we detected a failure to auto-save, + Or 0 if we didn't have a failure. */ + time_t auto_save_failure_time; + + /* Position in buffer at which display started + the last time this buffer was displayed. */ + ptrdiff_t last_window_start; + + /* If the long line scan cache is enabled (i.e. the buffer-local + variable cache-long-line-scans is non-nil), newline_cache + points to the newline cache, and width_run_cache points to the + width run cache. + + The newline cache records which stretches of the buffer are + known *not* to contain newlines, so that they can be skipped + quickly when we search for newlines. + + The width run cache records which stretches of the buffer are + known to contain characters whose widths are all the same. If + the width run cache maps a character to a value > 0, that value is + the character's width; if it maps a character to zero, we don't + know what its width is. This allows compute_motion to process + such regions very quickly, using algebra instead of inspecting + each character. See also width_table, below. */ + struct region_cache *newline_cache; + struct region_cache *width_run_cache; + + /* Non-zero means don't use redisplay optimizations for + displaying this buffer. */ + unsigned prevent_redisplay_optimizations_p : 1; + + /* Non-zero whenever the narrowing is changed in this buffer. */ + unsigned clip_changed : 1; + + /* List of overlays that end at or before the current center, + in order of end-position. */ + struct Lisp_Overlay *overlays_before; + + /* List of overlays that end after the current center, + in order of start-position. */ + struct Lisp_Overlay *overlays_after; + + /* Position where the overlay lists are centered. */ + ptrdiff_t overlay_center; + + /* Changes in the buffer are recorded here for undo, and t means + don't record anything. This information belongs to the base + buffer of an indirect buffer. But we can't store it in the + struct buffer_text because local variables have to be right in + the struct buffer. So we copy it around in set_buffer_internal. */ + Lisp_Object BUFFER_INTERNAL_FIELD (undo_list); }; @@ -896,10 +917,10 @@ #define GET_OVERLAYS_AT(posn, overlays, noverlays, nextp, chrq) \ do { \ - ptrdiff_t maxlen = 40; \ + ptrdiff_t maxlen = 40; \ overlays = (Lisp_Object *) alloca (maxlen * sizeof (Lisp_Object)); \ noverlays = overlays_at (posn, 0, &overlays, &maxlen, \ - nextp, NULL, chrq); \ + nextp, NULL, chrq); \ if (noverlays > maxlen) \ { \ maxlen = noverlays; \ @@ -992,6 +1013,15 @@ #define PER_BUFFER_VAR_OFFSET(VAR) \ offsetof (struct buffer, BUFFER_INTERNAL_FIELD (VAR)) +/* Used to iterate over normal Lisp_Object fields of struct buffer (all + Lisp_Objects except undo_list). If you add, remove, or reorder + Lisp_Objects in a struct buffer, make sure that this is still correct. */ + +#define for_each_per_buffer_object_at(offset) \ + for (offset = PER_BUFFER_VAR_OFFSET (name); \ + offset <= PER_BUFFER_VAR_OFFSET (cursor_in_non_selected_windows); \ + offset += sizeof (Lisp_Object)) + /* Return the index of buffer-local variable VAR. Each per-buffer variable has an index > 0 associated with it, except when it always has buffer-local values, in which case the index is -1. If this is ------------------------------------------------------------ revno: 108835 committer: Glenn Morris branch nick: trunk timestamp: Mon 2012-07-02 22:16:11 -0400 message: Tweak bug-reference-bug-regexp setting * lisp/progmodes/bug-reference.el (bug-reference-bug-regexp): Allow linking to specific messages in debbugs reports (eg 123#5). diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-02 16:21:54 +0000 +++ lisp/ChangeLog 2012-07-03 02:16:11 +0000 @@ -1,3 +1,8 @@ +2012-07-03 Glenn Morris + + * progmodes/bug-reference.el (bug-reference-bug-regexp): + Allow linking to specific messages in debbugs reports (eg 123#5). + 2012-07-02 Chong Yidong * xml.el: Fix entity and character reference expansion, allowing === modified file 'lisp/progmodes/bug-reference.el' --- lisp/progmodes/bug-reference.el 2012-01-19 07:21:25 +0000 +++ lisp/progmodes/bug-reference.el 2012-07-03 02:16:11 +0000 @@ -62,7 +62,7 @@ (get s 'bug-reference-url-format))))) (defconst bug-reference-bug-regexp - "\\([Bb]ug ?#\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\)" + "\\([Bb]ug ?#\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" "Regular expression which matches bug references.") (defun bug-reference-set-overlay-properties () ------------------------------------------------------------ revno: 108834 committer: Katsumi Yamaoka branch nick: trunk timestamp: Tue 2012-07-03 00:25:57 +0000 message: gnus-art.el (gnus-article-view-part): Toggle subparts of multipart/alternative part diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2012-07-02 00:48:41 +0000 +++ lisp/gnus/ChangeLog 2012-07-03 00:25:57 +0000 @@ -1,3 +1,8 @@ +2012-07-03 Katsumi Yamaoka + + * gnus-art.el (gnus-article-view-part): + Toggle subparts of multipart/alternative part. + 2012-07-02 Katsumi Yamaoka * gnus-sync.el: Simply require json. === modified file 'lisp/gnus/gnus-art.el' --- lisp/gnus/gnus-art.el 2012-06-26 22:52:31 +0000 +++ lisp/gnus/gnus-art.el 2012-07-03 00:25:57 +0000 @@ -5621,7 +5621,9 @@ (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) (when (gnus-article-goto-part n) (if (equal (car handle) "multipart/alternative") - (gnus-article-press-button) + (progn + (beginning-of-line) ;; Make it toggle subparts + (gnus-article-press-button)) (when (eq (gnus-mm-display-part handle) 'internal) (gnus-set-window-start))))))) ------------------------------------------------------------ revno: 108833 committer: Chong Yidong branch nick: trunk timestamp: Tue 2012-07-03 00:21:54 +0800 message: * lisp/xml.el: Handle entity and character reference expansion correctly. (xml-default-ns): New variable. (xml-entity-alist): Use XML spec definitions for lt and amp. (xml-parse-region): Make first two arguments optional. Discard text properties. (xml-parse-tag-1): New function, spun off from xml-parse-tag. All callers changed. (xml-parse-tag): Call xml-parse-tag-1. For backward compatibility, this function should not modify buffer contents. (xml-parse-tag-1): Fix opening-tag regexp. (xml-parse-string): Rewrite, handling entity and character references properly. (xml--entity-replacement-text): Signal an error if a parameter entity is undefined. * test/automated/xml-parse-tests.el (xml-parse-tests--data): More testcases. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-02 16:18:02 +0000 +++ lisp/ChangeLog 2012-07-02 16:21:54 +0000 @@ -1,3 +1,21 @@ +2012-07-02 Chong Yidong + + * xml.el: Fix entity and character reference expansion, allowing + them to expand into markup as per XML spec. + (xml-default-ns): New variable. + (xml-entity-alist): Use XML spec definitions for lt and amp. + (xml-parse-region): Make first two arguments optional. Discard + text properties. + (xml-parse-tag-1): New function, spun off from xml-parse-tag. All + callers changed. + (xml-parse-tag): Call xml-parse-tag-1. For backward + compatibility, this function should not modify buffer contents. + (xml-parse-tag-1): Fix opening-tag regexp. + (xml-parse-string): Rewrite, handling entity and character + references properly. + (xml--entity-replacement-text): Signal an error if a parameter + entity is undefined. + 2012-07-02 Stefan Monnier * comint.el (comint-output-filter): Filter out repeated prompts. === modified file 'lisp/xml.el' --- lisp/xml.el 2012-07-01 11:05:17 +0000 +++ lisp/xml.el 2012-07-02 16:21:54 +0000 @@ -80,22 +80,23 @@ ;; a worthwhile tradeoff especially since we're usually parsing files ;; instead of hand-crafted XML. -;;******************************************************************* -;;** -;;** Macros to parse the list -;;** -;;******************************************************************* +;;; Macros to parse the list (defconst xml-undefined-entity "?" "What to substitute for undefined entities") +(defconst xml-default-ns '(("" . "") + ("xml" . "http://www.w3.org/XML/1998/namespace") + ("xmlns" . "http://www.w3.org/2000/xmlns/")) + "Alist mapping default XML namespaces to their URIs.") + (defvar xml-entity-alist - '(("lt" . "<") + '(("lt" . "<") ("gt" . ">") ("apos" . "'") ("quot" . "\"") - ("amp" . "&")) - "Alist of defined XML entities.") + ("amp" . "&")) + "Alist mapping XML entities to their replacement text.") (defvar xml-parameter-entity-alist nil "Alist of defined XML parametric entities.") @@ -156,11 +157,7 @@ See also `xml-get-attribute-or-nil'." (or (xml-get-attribute-or-nil node attribute) "")) -;;******************************************************************* -;;** -;;** Creating the list -;;** -;;******************************************************************* +;;; Creating the list ;;;###autoload (defun xml-parse-file (file &optional parse-dtd parse-ns) @@ -299,8 +296,10 @@ ;; prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? ;;;###autoload -(defun xml-parse-region (beg end &optional buffer parse-dtd parse-ns) +(defun xml-parse-region (&optional beg end buffer parse-dtd parse-ns) "Parse the region from BEG to END in BUFFER. +If BEG is nil, it defaults to `point-min'. +If END is nil, it defaults to `point-max'. If BUFFER is nil, it defaults to the current buffer. Returns the XML list for the region, or raises an error if the region is not well-formed XML. @@ -312,7 +311,7 @@ (unless buffer (setq buffer (current-buffer))) (with-temp-buffer - (insert-buffer-substring buffer beg end) + (insert-buffer-substring-no-properties buffer beg end) (xml--parse-buffer parse-dtd parse-ns))) (defun xml--parse-buffer (parse-dtd parse-ns) @@ -327,7 +326,7 @@ (if (search-forward "<" nil t) (progn (forward-char -1) - (setq result (xml-parse-tag parse-dtd parse-ns)) + (setq result (xml-parse-tag-1 parse-dtd parse-ns)) (cond ((null result) ;; Not looking at an xml start tag. @@ -379,8 +378,7 @@ (xml-parameter-entity-alist xml-parameter-entity-alist) children) (while (not (eobp)) - (let ((bit (xml-parse-tag - parse-dtd parse-ns))) + (let ((bit (xml-parse-tag-1 parse-dtd parse-ns))) (if children (setq children (append (list bit) children)) (if (stringp bit) @@ -392,30 +390,32 @@ "Parse the tag at point. If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and returned as the first element in the list. -If PARSE-NS is non-nil, then QNAMES are expanded. -Returns one of: +If PARSE-NS is non-nil, expand QNAMES; if the value of PARSE-NS +is a list, use it as an alist mapping namespaces to URIs. + +Return one of: - a list : the matching node - nil : the point is not looking at a tag. - a pair : the first element is the DTD, the second is the node." + (let ((buf (current-buffer)) + (pos (point))) + (with-temp-buffer + (insert-buffer-substring-no-properties buf pos) + (goto-char (point-min)) + (xml-parse-tag-1 parse-dtd parse-ns)))) + +(defun xml-parse-tag-1 (&optional parse-dtd parse-ns) + "Like `xml-parse-tag', but possibly modify the buffer while working." (let ((xml-validating-parser (or parse-dtd xml-validating-parser)) - (xml-ns (if (consp parse-ns) - parse-ns - (if parse-ns - (list - ;; Default for empty prefix is no namespace - (cons "" "") - ;; "xml" namespace - (cons "xml" "http://www.w3.org/XML/1998/namespace") - ;; We need to seed the xmlns namespace - (cons "xmlns" "http://www.w3.org/2000/xmlns/")))))) + (xml-ns (cond ((consp parse-ns) parse-ns) + (parse-ns xml-default-ns)))) (cond - ;; Processing instructions (like the tag at the - ;; beginning of a document). + ;; Processing instructions, like . ((looking-at "<\\?") (search-forward "?>") (skip-syntax-forward " ") - (xml-parse-tag parse-dtd xml-ns)) - ;; Character data (CDATA) sections, in which no tag should be interpreted + (xml-parse-tag-1 parse-dtd xml-ns)) + ;; Character data (CDATA) sections, in which no tag should be interpreted ((looking-at "" nil t) @@ -423,33 +423,32 @@ (concat (buffer-substring-no-properties pos (match-beginning 0)) (xml-parse-string)))) - ;; DTD for the document + ;; DTD for the document ((looking-at "") + ;; FIXME: This loses the skipped-over spaces. (skip-syntax-forward " ") (unless (eobp) (let ((xml-sub-parser t)) - (xml-parse-tag parse-dtd xml-ns)))) - ;; end tag + (xml-parse-tag-1 parse-dtd xml-ns)))) + ;; end tag ((looking-at "[:space:]]+\\)") + ;; opening tag + ((looking-at (eval-when-compile (concat "<\\(" xml-name-re "\\)"))) (goto-char (match-end 1)) - ;; Parse this node (let* ((node-name (match-string-no-properties 1)) ;; Parse the attribute list. (attrs (xml-parse-attlist xml-ns)) children) - ;; add the xmlns:* attrs to our cache (when (consp xml-ns) (dolist (attr attrs) @@ -458,70 +457,114 @@ (caar attr))) (push (cons (cdar attr) (cdr attr)) xml-ns)))) - (setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns))) - - ;; is this an empty element ? - (if (looking-at "/>") - (progn - (forward-char 2) - (nreverse children)) - - ;; is this a valid start tag ? - (if (eq (char-after) ?>) - (progn - (forward-char 1) - ;; Now check that we have the right end-tag. Note that this - ;; one might contain spaces after the tag name - (let ((end (concat ""))) - (while (not (looking-at end)) - (cond - ((looking-at "", but didn't see it.) - (error "XML: (Well-Formed) Couldn't parse tag: %s" - (buffer-substring-no-properties (- (point) 10) (+ (point) 1))))))) - (t ;; (Not one of PI, CDATA, Comment, End tag, or Start tag) - (unless xml-sub-parser ; Usually, we error out. + (cond + ;; is this an empty element ? + ((looking-at "/>") + (forward-char 2) + (nreverse children)) + ;; is this a valid start tag ? + ((eq (char-after) ?>) + (forward-char 1) + ;; Now check that we have the right end-tag. + (let ((end (concat ""))) + (while (not (looking-at end)) + (cond + ((eobp) + (error "XML: (Not Well-Formed) End of buffer while reading element `%s'" + node-name)) + ((looking-at "" nil t) + (match-beginning 0) + (point-max)))) + node-name)) + ;; Read a sub-element and push it onto CHILDREN. + ((= (char-after) ?<) + (let ((tag (xml-parse-tag-1 nil xml-ns))) + (when tag + (push tag children)))) + ;; Read some character data. + (t + (let ((expansion (xml-parse-string))) + (push (if (stringp (car children)) + ;; If two strings were separated by a + ;; comment, concat them. + (concat (pop children) expansion) + expansion) + children))))) + ;; Move point past the end-tag. + (goto-char (match-end 0)) + (nreverse children))) + ;; Otherwise this was an invalid start tag (expected ">" not found.) + (t + (error "XML: (Well-Formed) Couldn't parse tag: %s" + (buffer-substring-no-properties (- (point) 10) (+ (point) 1))))))) + + ;; (Not one of PI, CDATA, Comment, End tag, or Start tag) + (t + (unless xml-sub-parser ; Usually, we error out. (error "XML: (Well-Formed) Invalid character")) - ;; However, if we're parsing incrementally, then we need to deal ;; with stray CDATA. (xml-parse-string))))) (defun xml-parse-string () - "Parse the next whatever. Could be a string, or an element." - (let* ((pos (point)) - (string (progn (skip-chars-forward "^<") - (buffer-substring-no-properties pos (point))))) - ;; Clean up the string. As per XML specifications, the XML - ;; processor should always pass the whole string to the - ;; application. But \r's should be replaced: - ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends - (setq pos 0) - (while (string-match "\r\n?" string pos) - (setq string (replace-match "\n" t t string)) - (setq pos (1+ (match-beginning 0)))) - - (xml-substitute-special string))) + "Parse character data at point, and return it as a string. +Leave point at the start of the next thing to parse. This +function can modify the buffer by expanding entity and character +references." + (let ((start (point)) + ref val) + (while (and (not (eobp)) + (not (looking-at "<"))) + ;; Find the next < or & character. + (skip-chars-forward "^<&") + (when (eq (char-after) ?&) + ;; If we find an entity or character reference, expand it. + (unless (looking-at (eval-when-compile + (concat "&\\(?:#\\([0-9]+\\)\\|#x\\([0-9a-fA-F]+\\)\\|\\(" + xml-name-re "\\)\\);"))) + (error "XML: (Not Well-Formed) Invalid entity reference")) + ;; For a character reference, the next entity or character + ;; reference must be after the replacement. [4.6] "Numerical + ;; character references are expanded immediately when + ;; recognized and MUST be treated as character data." + (cond ((setq ref (match-string 1)) + ;; Decimal character reference + (setq val (save-match-data + (decode-char 'ucs (string-to-number ref)))) + (and (null val) + xml-validating-parser + (error "XML: (Validity) Invalid character `%s'" ref)) + (replace-match (or (string val) xml-undefined-entity) t t)) + ;; Hexadecimal character reference + ((setq ref (match-string 2)) + (setq val (save-match-data + (decode-char 'ucs (string-to-number ref 16)))) + (and (null val) + xml-validating-parser + (error "XML: (Validity) Invalid character `x%s'" ref)) + (replace-match (or (string val) xml-undefined-entity) t t)) + ;; For an entity reference, search again from the start + ;; of the replaced text, since the replacement can + ;; contain entity or character references, or markup. + ((setq ref (match-string 3)) + (setq val (assoc ref xml-entity-alist)) + (and (null val) + xml-validating-parser + (error "XML: (Validity) Undefined entity `%s'" ref)) + (replace-match (cdr val) t t) + (goto-char (match-beginning 0)))))) + ;; [2.11] Clean up line breaks. + (let ((end-marker (point-marker))) + (goto-char start) + (while (re-search-forward "\r\n?" end-marker t) + (replace-match "\n" t t)) + (goto-char end-marker) + (buffer-substring start (point))))) (defun xml-parse-attlist (&optional xml-ns) "Return the attribute-list after point. @@ -564,15 +607,11 @@ (skip-syntax-forward " ")) (nreverse attlist))) -;;******************************************************************* -;;** -;;** The DTD (document type declaration) -;;** The following functions know how to skip or parse the DTD of -;;** a document -;;** -;;******************************************************************* +;;; DTD (document type declaration) -;; Fixme: This fails at least if the DTD contains conditional sections. +;; The following functions know how to skip or parse the DTD of a +;; document. FIXME: it fails at least if the DTD contains conditional +;; sections. (defun xml-skip-dtd () "Skip the DTD at point. @@ -789,9 +828,10 @@ ;; Parameter entity reference ((setq ref (match-string 3 string)) (setq val (assoc ref xml-parameter-entity-alist)) - (if val - (push (cdr val) children) - (push (concat "%" ref ";") children)))) + (and (null val) + xml-validating-parser + (error "XML: (Validity) Undefined parameter entity `%s'" ref)) + (push (or (cdr val) xml-undefined-entity) children))) (setq string remainder))) (mapconcat 'identity (nreverse (cons string children)) ""))) @@ -828,79 +868,40 @@ (t elem)))) -;;******************************************************************* -;;** -;;** Substituting special XML sequences -;;** -;;******************************************************************* +;;; Substituting special XML sequences (defun xml-substitute-special (string) - "Return STRING, after substituting entity references." - ;; This originally made repeated passes through the string from the - ;; beginning, which isn't correct, since then either "&amp;" or - ;; "&amp;" won't DTRT. - - (let ((point 0) - children end-point) - (while (string-match "&\\([^;]*\\);" string point) - (setq end-point (match-end 0)) - (let* ((this-part (match-string-no-properties 1 string)) - (prev-part (substring string point (match-beginning 0))) - (entity (assoc this-part xml-entity-alist)) - (expansion - (cond ((string-match "#\\([0-9]+\\)" this-part) - (let ((c (decode-char - 'ucs - (string-to-number (match-string-no-properties 1 this-part))))) - (if c (string c)))) - ((string-match "#x\\([[:xdigit:]]+\\)" this-part) - (let ((c (decode-char - 'ucs - (string-to-number (match-string-no-properties 1 this-part) 16)))) - (if c (string c)))) - (entity - (cdr entity)) - ((eq (length this-part) 0) - (error "XML: (Not Well-Formed) No entity given")) - (t - (if xml-validating-parser - (error "XML: (Validity) Undefined entity `%s'" - this-part) - xml-undefined-entity))))) - - (cond ((null children) - ;; FIXME: If we have an entity that expands into XML, this won't work. - (setq children - (concat prev-part expansion))) - ((stringp children) - (if (stringp expansion) - (setq children (concat children prev-part expansion)) - (setq children (list expansion (concat prev-part children))))) - ((and (stringp expansion) - (stringp (car children))) - (setcar children (concat prev-part expansion (car children)))) - ((stringp expansion) - (setq children (append (concat prev-part expansion) - children))) - ((stringp (car children)) - (setcar children (concat (car children) prev-part)) - (setq children (append expansion children))) - (t - (setq children (list expansion - prev-part - children)))) - (setq point end-point))) - (cond ((stringp children) - (concat children (substring string point))) - ((stringp (car (last children))) - (concat (car (last children)) (substring string point))) - ((null children) - string) - (t - (concat (mapconcat 'identity - (nreverse children) - "") - (substring string point)))))) + "Return STRING, after substituting entity and character references. +STRING is assumed to occur in an XML attribute value." + (let ((ref-re (eval-when-compile + (concat "&\\(?:#\\(x\\)?\\([0-9]+\\)\\|\\(" + xml-name-re "\\)\\);"))) + children) + (while (string-match ref-re string) + (push (substring string 0 (match-beginning 0)) children) + (let* ((remainder (substring string (match-end 0))) + (ref (match-string 2 string))) + (if ref + ;; [4.6] Character references are included as + ;; character data. + (let ((val (decode-char 'ucs (string-to-number + ref (if (match-string 1 string) 16))))) + (push (cond (val (string val)) + (xml-validating-parser + (error "XML: (Validity) Undefined character `x%s'" ref)) + (t xml-undefined-entity)) + children) + (setq string remainder)) + ;; [4.4.5] Entity references are "included in literal". + ;; Note that we don't need do anything special to treat + ;; quotes as normal data characters. + (setq ref (match-string 3 string)) + (let ((val (or (cdr (assoc ref xml-entity-alist)) + (if xml-validating-parser + (error "XML: (Validity) Undefined entity `%s'" ref) + xml-undefined-entity)))) + (setq string (concat val remainder)))))) + (mapconcat 'identity (nreverse (cons string children)) ""))) (defun xml-substitute-numeric-entities (string) "Substitute SGML numeric entities by their respective utf characters. @@ -921,12 +922,7 @@ string) nil)) -;;******************************************************************* -;;** -;;** Printing a tree. -;;** This function is intended mainly for debugging purposes. -;;** -;;******************************************************************* +;;; Printing a parse tree (mainly for debugging). (defun xml-debug-print (xml &optional indent-string) "Outputs the XML in the current buffer. === modified file 'test/ChangeLog' --- test/ChangeLog 2012-07-01 07:17:05 +0000 +++ test/ChangeLog 2012-07-02 16:21:54 +0000 @@ -1,3 +1,8 @@ +2012-07-02 Chong Yidong + + * automated/xml-parse-tests.el (xml-parse-tests--data): More + testcases. + 2012-07-01 Chong Yidong * automated/xml-parse-tests.el: New file. === modified file 'test/automated/xml-parse-tests.el' --- test/automated/xml-parse-tests.el 2012-07-01 11:05:17 +0000 +++ test/automated/xml-parse-tests.el 2012-07-02 16:21:54 +0000 @@ -33,15 +33,26 @@ '(;; General entity substitution ("]>&ent;;" . ((foo ((a . "b")) (bar nil "AbC;")))) + ("&amp;&apos;'<>"" . + ((foo () "&''<>\""))) ;; Parameter entity substitution ("]>&ent;;" . ((foo ((a . "b")) (bar nil "AbC;")))) ;; Tricky parameter entity substitution (like XML spec Appendix D) ("' > %xx; ]>A&ent;C" . - ((foo nil "AbC"))) + ((foo () "AbC"))) ;; Bug#7172 (" ]>" . - ((foo nil)))) + ((foo ()))) + ;; Entities referencing entities, in character data + ("]>&abc;" . + ((foo () "aBc"))) + ;; Entities referencing entities, in attribute values + ("]>1" . + ((foo ((a . "-aBc-")) "1"))) + ;; Character references must be treated as character data + ("AT&T;" . ((foo () "AT&T;"))) + ("&amp;" . ((foo () "&")))) "Alist of XML strings and their expected parse trees.") (ert-deftest xml-parse-tests () ------------------------------------------------------------ revno: 108832 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-07-02 12:18:02 -0400 message: * lisp/comint.el (comint-output-filter): Filter out repeated prompts. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-02 13:31:15 +0000 +++ lisp/ChangeLog 2012-07-02 16:18:02 +0000 @@ -1,5 +1,7 @@ 2012-07-02 Stefan Monnier + * comint.el (comint-output-filter): Filter out repeated prompts. + * net/ange-ftp.el (ange-ftp-expand-file-name): Use ange-ftp-ftp-name and file-name-absolute-p. (ange-ftp-file-exists-p): Use ange-ftp-file-exists-p for === modified file 'lisp/comint.el' --- lisp/comint.el 2012-06-30 21:23:38 +0000 +++ lisp/comint.el 2012-07-02 16:18:02 +0000 @@ -2006,6 +2006,20 @@ (goto-char (process-mark process)) (set-marker comint-last-output-start (point)) + ;; Try to skip repeated prompts, which can occur as a result of + ;; commands sent without inserting them in the buffer. + (let ((bol (save-excursion (forward-line 0) (point)))) ;No fields. + (when (and (not (bolp)) + (looking-back comint-prompt-regexp bol)) + (let* ((prompt (buffer-substring bol (point))) + (prompt-re (concat "\\`" (regexp-quote prompt)))) + (while (string-match prompt-re string) + (setq string (substring string (match-end 0))))))) + (while (string-match (concat "\\(^" comint-prompt-regexp + "\\)\\1+") + string) + (setq string (replace-match "\\1" nil nil string))) + ;; insert-before-markers is a bad thing. XXX ;; Luckily we don't have to use it any more, we use ;; window-point-insertion-type instead. @@ -2672,6 +2686,7 @@ the case, this command just calls `kill-region' with all read-only properties intact. The read-only status of newlines is updated using `comint-update-fence', if necessary." + (declare (advertised-calling-convention (beg end) "23.3")) (interactive "r") (save-excursion (let* ((true-beg (min beg end)) @@ -2690,8 +2705,6 @@ (let ((inhibit-read-only t)) (kill-region beg end yank-handler) (comint-update-fence)))))) -(set-advertised-calling-convention 'comint-kill-region '(beg end) "23.3") - ;; Support for source-file processing commands. ;;============================================================================ ------------------------------------------------------------ revno: 108831 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2012-07-02 09:31:15 -0400 message: * lisp/net/ange-ftp.el (ange-ftp-expand-file-name): Use ange-ftp-ftp-name and file-name-absolute-p. (ange-ftp-file-exists-p): Use ange-ftp-file-exists-p for internal calls. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-02 08:00:05 +0000 +++ lisp/ChangeLog 2012-07-02 13:31:15 +0000 @@ -1,3 +1,10 @@ +2012-07-02 Stefan Monnier + + * net/ange-ftp.el (ange-ftp-expand-file-name): Use ange-ftp-ftp-name + and file-name-absolute-p. + (ange-ftp-file-exists-p): Use ange-ftp-file-exists-p for + internal calls. + 2012-07-02 Paul Eggert Spelling fixes. @@ -50,7 +57,7 @@ 2012-06-30 Stefan Monnier - * emacs-lisp/cl-lib.el: Require macroexp for its macros. + * emacs-lisp/cl-lib.el: Require macroexp. 2012-06-30 Chong Yidong === modified file 'lisp/net/ange-ftp.el' --- lisp/net/ange-ftp.el 2012-07-02 08:00:05 +0000 +++ lisp/net/ange-ftp.el 2012-07-02 13:31:15 +0000 @@ -3143,21 +3143,15 @@ "Documented as `expand-file-name'." (save-match-data (setq default (or default default-directory)) - (cond ((eq (string-to-char name) ?~) - (ange-ftp-real-expand-file-name name)) - ((eq (string-to-char name) ?/) - (ange-ftp-canonize-filename name)) - ((and (eq system-type 'windows-nt) - (eq (string-to-char name) ?\\)) - (ange-ftp-canonize-filename name)) - ((and (eq system-type 'windows-nt) - (or (string-match "\\`[a-zA-Z]:" name) - (string-match "\\`[a-zA-Z]:" default))) - (ange-ftp-real-expand-file-name name default)) - ((zerop (length name)) - (ange-ftp-canonize-filename default)) - ((ange-ftp-canonize-filename - (concat (file-name-as-directory default) name)))))) + (cond + ((ange-ftp-ftp-name name) + ;; `default' is irrelevant. + (ange-ftp-canonize-filename name)) + ((file-name-absolute-p name) + ;; `name' is absolute but is not an ange-ftp name => not ange-ftp. + (ange-ftp-real-expand-file-name name "/")) + ((ange-ftp-canonize-filename + (concat (file-name-as-directory default) name)))))) ;;; These are problems--they are currently not enabled. @@ -3390,7 +3384,7 @@ (if (ange-ftp-file-entry-p name) (let ((file-ent (ange-ftp-get-file-entry name))) (if (stringp file-ent) - (file-exists-p + (ange-ftp-file-exists-p (ange-ftp-expand-symlink file-ent (file-name-directory (directory-file-name name)))) ------------------------------------------------------------ revno: 108830 committer: Dmitry Antipov branch nick: trunk timestamp: Mon 2012-07-02 14:08:41 +0400 message: * src/ChangeLog: Fix a typo. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-02 07:36:17 +0000 +++ src/ChangeLog 2012-07-02 10:08:41 +0000 @@ -9,7 +9,7 @@ * alloc.c (mark_buffer): Simplify. Remove prototype. (mark_object): Add comment. Reorganize marking of vector-like - objects. Use CHECK_LIVE for all vector-like ojects except buffers + objects. Use CHECK_LIVE for all vector-like objects except buffers and subroutines when GC_CHECK_MARKED_OBJECTS is defined. Avoid redundant calls to mark_vectorlike for bool vectors. ------------------------------------------------------------ revno: 108829 committer: Paul Eggert branch nick: trunk timestamp: Mon 2012-07-02 01:00:05 -0700 message: Spelling fixes. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-06-28 10:40:24 +0000 +++ etc/NEWS 2012-07-02 08:00:05 +0000 @@ -164,8 +164,8 @@ The variables `term-default-fg-color' and `term-default-bg-color' are now deprecated in favor of the `term-face' face, that you can -customize. Also, it is now possible to cutomize how are displayed the -ANSI terminal colors and styles by cutomizing the corresponding +customize. Also, it is now possible to customize how are displayed the +ANSI terminal colors and styles by customizing the corresponding `term-color-', `term-color-underline' and `term-color-bold' faces. === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-01 11:05:17 +0000 +++ lisp/ChangeLog 2012-07-02 08:00:05 +0000 @@ -1,3 +1,9 @@ +2012-07-02 Paul Eggert + + Spelling fixes. + * emacs-lisp/bytecomp.el (byte-compile--reify-function): + Rename from byte-compile--refiy-function. All uses changed. + 2012-07-01 Chong Yidong * xml.el (xml--parse-buffer): New function. Move most of === modified file 'lisp/emacs-lisp/byte-opt.el' --- lisp/emacs-lisp/byte-opt.el 2012-06-28 03:31:27 +0000 +++ lisp/emacs-lisp/byte-opt.el 2012-07-02 08:00:05 +0000 @@ -284,7 +284,7 @@ ;; been preprocessed! `(function ,fn) (byte-compile-preprocess - (byte-compile--refiy-function fn))))) + (byte-compile--reify-function fn))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) (byte-compile-log-warning === modified file 'lisp/emacs-lisp/bytecomp.el' --- lisp/emacs-lisp/bytecomp.el 2012-06-28 03:31:27 +0000 +++ lisp/emacs-lisp/bytecomp.el 2012-07-02 08:00:05 +0000 @@ -2367,7 +2367,7 @@ ;;(byte-compile-set-symbol-position name) (byte-compile-warn "probable `\"' without `\\' in doc string of %s" name)) - + (if (not (listp body)) ;; The precise definition requires evaluation to find out, so it ;; will only be known at runtime. @@ -2451,7 +2451,7 @@ (- (position-bytes (point)) (point-min) -1) (goto-char (point-max)))))) -(defun byte-compile--refiy-function (fun) +(defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. FUN should be either a `lambda' value or a `closure' value." (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) @@ -2488,7 +2488,7 @@ (when (symbolp form) (unless (memq (car-safe fun) '(closure lambda)) (error "Don't know how to compile %S" fun)) - (setq fun (byte-compile--refiy-function fun)) + (setq fun (byte-compile--reify-function fun)) (setq lexical-binding (eq (car fun) 'closure))) (unless (eq (car-safe fun) 'lambda) (error "Don't know how to compile %S" fun)) === modified file 'lisp/loadup.el' --- lisp/loadup.el 2012-06-30 21:10:50 +0000 +++ lisp/loadup.el 2012-07-02 08:00:05 +0000 @@ -256,12 +256,12 @@ (load "site-load" t) ;; ¡¡¡ Big Ugly Hack !!! -;; src/boostrap-emacs is mostly used to compile .el files, so it needs +;; src/bootstrap-emacs is mostly used to compile .el files, so it needs ;; macroexp, bytecomp, cconv, and byte-opt to be fast. Generally this is done ;; by compiling those files first, but this only makes a difference if those ;; files are not preloaded. As it so happens, macroexp.el tends to be -;; accidentally preloaded in src/boostrap-emacs because cl.el and cl-macs.el -;; require it. So lets unload it here, if needed, to make sure the +;; accidentally preloaded in src/bootstrap-emacs because cl.el and cl-macs.el +;; require it. So let's unload it here, if needed, to make sure the ;; byte-compiled version is used. (if (or (not (fboundp 'macroexpand-all)) (byte-code-function-p (symbol-function 'macroexpand-all))) === modified file 'lisp/net/ange-ftp.el' --- lisp/net/ange-ftp.el 2012-06-29 07:14:36 +0000 +++ lisp/net/ange-ftp.el 2012-07-02 08:00:05 +0000 @@ -1201,7 +1201,7 @@ (defun ange-ftp-get-passwd (host user) "Return the password for specified HOST and USER, asking user if necessary." ;; If `non-essential' is non-nil, don't ask for a password. It will - ;; be catched in Tramp. + ;; be caught in Tramp. (when non-essential (throw 'non-essential 'non-essential)) @@ -1781,7 +1781,7 @@ (defun ange-ftp-gwp-start (host user name args) "Login to the gateway machine and fire up an FTP process." ;; If `non-essential' is non-nil, don't reopen a new connection. It - ;; will be catched in Tramp. + ;; will be caught in Tramp. (when non-essential (throw 'non-essential 'non-essential)) (let (;; It would be nice to make process-connection-type nil, @@ -1916,7 +1916,7 @@ If HOST is only FTP-able through a gateway machine then spawn a shell on the gateway machine to do the FTP instead." ;; If `non-essential' is non-nil, don't reopen a new connection. It - ;; will be catched in Tramp. + ;; will be caught in Tramp. (when non-essential (throw 'non-essential 'non-essential)) (let* ((use-gateway (ange-ftp-use-gateway-p host)) @@ -2138,7 +2138,7 @@ (if (and proc (memq (process-status proc) '(run open))) proc ;; If `non-essential' is non-nil, don't reopen a new connection. It - ;; will be catched in Tramp. + ;; will be caught in Tramp. (when non-essential (throw 'non-essential 'non-essential)) === modified file 'lisp/org/ChangeLog' --- lisp/org/ChangeLog 2012-06-17 08:53:31 +0000 +++ lisp/org/ChangeLog 2012-07-02 08:00:05 +0000 @@ -11671,7 +11671,7 @@ 2010-11-11 Dan Davison * org.el (org-src-fontify-natively): Set to nil by default. - Supply cutomize interface. + Supply customize interface. 2010-11-11 Bastien Guerry === modified file 'src/dosfns.c' --- src/dosfns.c 2012-06-30 15:32:51 +0000 +++ src/dosfns.c 2012-07-02 08:00:05 +0000 @@ -23,7 +23,7 @@ /* The entire file is within this conditional */ #include -/* gettine and settime in dos.h clash with their namesakes from +/* gettime and settime in dos.h clash with their namesakes from gnulib, so we move out of our way the prototypes in dos.h. */ #define gettime dos_h_gettime_ #define settime dos_h_settime_ @@ -770,4 +770,3 @@ dos_decimal_point = 0; } #endif /* MSDOS */ - === modified file 'src/msdos.c' --- src/msdos.c 2012-06-30 15:32:51 +0000 +++ src/msdos.c 2012-07-02 08:00:05 +0000 @@ -31,7 +31,7 @@ #include #include #include -/* gettine and settime in dos.h clash with their namesakes from +/* gettime and settime in dos.h clash with their namesakes from gnulib, so we move out of our way the prototypes in dos.h. */ #define gettime dos_h_gettime_ #define settime dos_h_settime_ ------------------------------------------------------------ revno: 108828 committer: Paul Eggert branch nick: trunk timestamp: Mon 2012-07-02 00:36:17 -0700 message: * alloc.c (mark_object): Remove "#ifdef GC_CHECK_MARKED_OBJECTS" wrapper that is not needed because the wrapped code is a no-op (zero machine instructions) when GC_CHECK_MARKED_OBJECTS is not defined. This avoids a -Wunused-macros diagnostic with GCC 4.7.1 x86-64. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-02 06:23:15 +0000 +++ src/ChangeLog 2012-07-02 07:36:17 +0000 @@ -1,3 +1,10 @@ +2012-07-02 Paul Eggert + + * alloc.c (mark_object): Remove "#ifdef GC_CHECK_MARKED_OBJECTS" + wrapper that is not needed because the wrapped code is a no-op (zero + machine instructions) when GC_CHECK_MARKED_OBJECTS is not defined. + This avoids a -Wunused-macros diagnostic with GCC 4.7.1 x86-64. + 2012-07-02 Dmitry Antipov * alloc.c (mark_buffer): Simplify. Remove prototype. === modified file 'src/alloc.c' --- src/alloc.c 2012-07-02 06:23:15 +0000 +++ src/alloc.c 2012-07-02 07:36:17 +0000 @@ -5924,10 +5924,8 @@ else pvectype = 0; -#ifdef GC_CHECK_MARKED_OBJECTS if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER) CHECK_LIVE (live_vector_p); -#endif /* GC_CHECK_MARKED_OBJECTS */ if (pvectype == PVEC_BUFFER) { ------------------------------------------------------------ revno: 108827 committer: Dmitry Antipov branch nick: trunk timestamp: Mon 2012-07-02 10:23:15 +0400 message: * alloc.c (mark_buffer): Simplify. Remove prototype. (mark_object): Add comment. Reorganize marking of vector-like objects. Use CHECK_LIVE for all vector-like ojects except buffers and subroutines when GC_CHECK_MARKED_OBJECTS is defined. Avoid redundant calls to mark_vectorlike for bool vectors. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-30 21:35:20 +0000 +++ src/ChangeLog 2012-07-02 06:23:15 +0000 @@ -1,3 +1,11 @@ +2012-07-02 Dmitry Antipov + + * alloc.c (mark_buffer): Simplify. Remove prototype. + (mark_object): Add comment. Reorganize marking of vector-like + objects. Use CHECK_LIVE for all vector-like ojects except buffers + and subroutines when GC_CHECK_MARKED_OBJECTS is defined. Avoid + redundant calls to mark_vectorlike for bool vectors. + 2012-06-30 Glenn Morris * nsterm.m (ns_init_paths): Ignore site-lisp if --no-site-lisp. @@ -58,7 +66,7 @@ * window.h (struct window): Change type of 'fringes_outside_margins' to bitfield. Fix comment. Adjust users accordingly. - (struct window): Change type of 'window_end_bytepos' to ptrdiff_t. + (struct window): Change type of 'window_end_bytepos' to ptrdiff_t. Adjust comment. * xdisp.c (try_window_id): Change type of 'first_vpos' and 'vpos' to ptrdiff_t. === modified file 'src/alloc.c' --- src/alloc.c 2012-06-28 19:09:41 +0000 +++ src/alloc.c 2012-07-02 06:23:15 +0000 @@ -270,7 +270,6 @@ static Lisp_Object Qpost_gc_hook; -static void mark_buffer (Lisp_Object); static void mark_terminals (void); static void gc_sweep (void); static Lisp_Object make_pure_vector (ptrdiff_t); @@ -5787,6 +5786,48 @@ } } +/* Mark the pointers in a buffer structure. */ + +static void +mark_buffer (struct buffer *buffer) +{ + register Lisp_Object *ptr, tmp; + + eassert (!VECTOR_MARKED_P (buffer)); + VECTOR_MARK (buffer); + + MARK_INTERVAL_TREE (BUF_INTERVALS (buffer)); + + /* For now, we just don't mark the undo_list. It's done later in + a special way just before the sweep phase, and after stripping + some of its elements that are not needed any more. */ + + if (buffer->overlays_before) + { + XSETMISC (tmp, buffer->overlays_before); + mark_object (tmp); + } + if (buffer->overlays_after) + { + XSETMISC (tmp, buffer->overlays_after); + mark_object (tmp); + } + + /* buffer-local Lisp variables start at `undo_list', + tho only the ones from `name' on are GC'd normally. */ + for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name); + ptr <= &PER_BUFFER_VALUE (buffer, + PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER)); + ptr++) + mark_object (*ptr); + + /* If this is an indirect buffer, mark its base buffer. */ + if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer)) + mark_buffer (buffer->base_buffer); +} + +/* Determine type of generic Lisp_Object and mark it accordingly. */ + void mark_object (Lisp_Object arg) { @@ -5863,77 +5904,88 @@ break; case Lisp_Vectorlike: - if (VECTOR_MARKED_P (XVECTOR (obj))) - break; -#ifdef GC_CHECK_MARKED_OBJECTS - m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj) - && po != &buffer_defaults - && po != &buffer_local_symbols) - abort (); -#endif /* GC_CHECK_MARKED_OBJECTS */ - - if (BUFFERP (obj)) - { -#ifdef GC_CHECK_MARKED_OBJECTS - if (po != &buffer_defaults && po != &buffer_local_symbols) - { - struct buffer *b; - for (b = all_buffers; b && b != po; b = b->header.next.buffer) - ; - if (b == NULL) - abort (); - } -#endif /* GC_CHECK_MARKED_OBJECTS */ - mark_buffer (obj); - } - else if (SUBRP (obj)) - break; - else if (COMPILEDP (obj)) - /* We could treat this just like a vector, but it is better to - save the COMPILED_CONSTANTS element for last and avoid - recursion there. */ - { - register struct Lisp_Vector *ptr = XVECTOR (obj); - int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK; - int i; - + { + register struct Lisp_Vector *ptr = XVECTOR (obj); + register ptrdiff_t pvectype; + + if (VECTOR_MARKED_P (ptr)) + break; + +#ifdef GC_CHECK_MARKED_OBJECTS + m = mem_find (po); + if (m == MEM_NIL && !SUBRP (obj) + && po != &buffer_defaults + && po != &buffer_local_symbols) + abort (); +#endif /* GC_CHECK_MARKED_OBJECTS */ + + if (ptr->header.size & PSEUDOVECTOR_FLAG) + pvectype = ptr->header.size & PVEC_TYPE_MASK; + else + pvectype = 0; + +#ifdef GC_CHECK_MARKED_OBJECTS + if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER) CHECK_LIVE (live_vector_p); - VECTOR_MARK (ptr); /* Else mark it */ - for (i = 0; i < size; i++) /* and then mark its elements */ - { +#endif /* GC_CHECK_MARKED_OBJECTS */ + + if (pvectype == PVEC_BUFFER) + { +#ifdef GC_CHECK_MARKED_OBJECTS + if (po != &buffer_defaults && po != &buffer_local_symbols) + { + struct buffer *b = all_buffers; + for (; b && b != po; b = b->header.next.buffer) + ; + if (b == NULL) + abort (); + } +#endif /* GC_CHECK_MARKED_OBJECTS */ + mark_buffer ((struct buffer *) ptr); + } + + else if (pvectype == PVEC_COMPILED) + /* We could treat this just like a vector, but it is better + to save the COMPILED_CONSTANTS element for last and avoid + recursion there. */ + { + int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK; + int i; + + VECTOR_MARK (ptr); + for (i = 0; i < size; i++) if (i != COMPILED_CONSTANTS) mark_object (ptr->contents[i]); - } - obj = ptr->contents[COMPILED_CONSTANTS]; - goto loop; - } - else if (FRAMEP (obj)) - { - register struct frame *ptr = XFRAME (obj); - mark_vectorlike (XVECTOR (obj)); - mark_face_cache (ptr->face_cache); - } - else if (WINDOWP (obj)) - { - register struct Lisp_Vector *ptr = XVECTOR (obj); - struct window *w = XWINDOW (obj); + obj = ptr->contents[COMPILED_CONSTANTS]; + goto loop; + } + + else if (pvectype == PVEC_FRAME) + { + mark_vectorlike (ptr); + mark_face_cache (((struct frame *) ptr)->face_cache); + } + + else if (pvectype == PVEC_WINDOW) + { + struct window *w = (struct window *) ptr; + + mark_vectorlike (ptr); + /* Mark glyphs for leaf windows. Marking window + matrices is sufficient because frame matrices + use the same glyph memory. */ + if (NILP (w->hchild) && NILP (w->vchild) && w->current_matrix) + { + mark_glyph_matrix (w->current_matrix); + mark_glyph_matrix (w->desired_matrix); + } + } + + else if (pvectype == PVEC_HASH_TABLE) + { + struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr; + mark_vectorlike (ptr); - /* Mark glyphs for leaf windows. Marking window matrices is - sufficient because frame matrices use the same glyph - memory. */ - if (NILP (w->hchild) - && NILP (w->vchild) - && w->current_matrix) - { - mark_glyph_matrix (w->current_matrix); - mark_glyph_matrix (w->desired_matrix); - } - } - else if (HASH_TABLE_P (obj)) - { - struct Lisp_Hash_Table *h = XHASH_TABLE (obj); - mark_vectorlike ((struct Lisp_Vector *)h); /* If hash table is not weak, mark all keys and values. For weak tables, mark only the vector. */ if (NILP (h->weak)) @@ -5941,10 +5993,17 @@ else VECTOR_MARK (XVECTOR (h->key_and_value)); } - else if (CHAR_TABLE_P (obj)) - mark_char_table (XVECTOR (obj)); - else - mark_vectorlike (XVECTOR (obj)); + + else if (pvectype == PVEC_CHAR_TABLE) + mark_char_table (ptr); + + else if (pvectype == PVEC_BOOL_VECTOR) + /* No Lisp_Objects to mark in a bool vector. */ + VECTOR_MARK (ptr); + + else if (pvectype != PVEC_SUBR) + mark_vectorlike (ptr); + } break; case Lisp_Symbol: @@ -6091,52 +6150,6 @@ #undef CHECK_ALLOCATED #undef CHECK_ALLOCATED_AND_LIVE } - -/* Mark the pointers in a buffer structure. */ - -static void -mark_buffer (Lisp_Object buf) -{ - register struct buffer *buffer = XBUFFER (buf); - register Lisp_Object *ptr, tmp; - Lisp_Object base_buffer; - - eassert (!VECTOR_MARKED_P (buffer)); - VECTOR_MARK (buffer); - - MARK_INTERVAL_TREE (BUF_INTERVALS (buffer)); - - /* For now, we just don't mark the undo_list. It's done later in - a special way just before the sweep phase, and after stripping - some of its elements that are not needed any more. */ - - if (buffer->overlays_before) - { - XSETMISC (tmp, buffer->overlays_before); - mark_object (tmp); - } - if (buffer->overlays_after) - { - XSETMISC (tmp, buffer->overlays_after); - mark_object (tmp); - } - - /* buffer-local Lisp variables start at `undo_list', - tho only the ones from `name' on are GC'd normally. */ - for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name); - ptr <= &PER_BUFFER_VALUE (buffer, - PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER)); - ptr++) - mark_object (*ptr); - - /* If this is an indirect buffer, mark its base buffer. */ - if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer)) - { - XSETBUFFER (base_buffer, buffer->base_buffer); - mark_buffer (base_buffer); - } -} - /* Mark the Lisp pointers in the terminal objects. Called by Fgarbage_collect. */