cgit.sxemacs.org Git - packages/blob - xemacs-packages/mmm-mode/mmm-region.el

   1 ;;; mmm-region.el --- Manipulating and behavior of MMM submode regions
   2
   3 ;; Copyright (C) 2000 by Michael Abraham Shulman
   4
   5 ;; Author: Michael Abraham Shulman <viritrilbia@users.sourceforge.net>
   6 ;; Version: $Id: mmm-region.el,v 1.2 2008-12-22 14:02:24 mharnisch Exp $
   7
   8 ;;{{{ GPL
   9
  10 ;; This file is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This file is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;}}}
  26
  27 ;;; Commentary:
  28
  29 ;; This file provides the functions and variables to create, delete,
  30 ;; and inspect submode regions, as well as functions that make them
  31 ;; behave like the submode with respect to syntax tables, local maps,
  32 ;; font lock, etc.
  33
  34 ;; See mmm-class.el for functions which scan the buffer and decide
  35 ;; where to create regions.
  36
  37 ;;; Code:
  38
  39 (require 'cl)
  40 (require 'font-lock)
  41 (require 'mmm-compat)
  42 (require 'mmm-utils)
  43 (require 'mmm-auto)
  44 (require 'mmm-vars)
  45
  46 ;; INSPECTION
  47 ;;{{{ Current Overlays
  48
  49 ;; Emacs counts an overlay starting at POS as "at" POS, but not an
  50 ;; overlay ending at POS. XEmacs is more sensible and uses beg- and
  51 ;; end-stickiness to determine whether an endpoint is within an
  52 ;; extent. Here we want to act like XEmacs does.
  53
  54 (defsubst mmm-overlay-at (&optional pos type)
  55   "Return the highest-priority MMM Mode overlay at POS.
  56 See `mmm-included-p' for the values of TYPE."
  57   (car (mmm-overlays-at pos type)))
  58
  59 (defun mmm-overlays-at (&optional pos type)
  60   "Return a list of the MMM overlays at POS, in decreasing priority.
  61 See `mmm-included-p' for the values of TYPE."
  62   (or pos (setq pos (point)))
  63   (mmm-sort-overlays
  64    (remove-if-not
  65     #'(lambda (ovl)
  66         (and (overlay-get ovl 'mmm)
  67              (mmm-included-p ovl pos type)))
  68     ;; XEmacs complains about positions outside the buffer
  69     (overlays-in (max (1- pos) (point-min))
  70                  (min (1+ pos) (point-max))))))
  71
  72 (defun mmm-included-p (ovl pos &optional type)
  73   "Return true if the overlay OVL contains POS.
  74
  75 If OVL strictly contains POS, always return true.  If OVL starts or
  76 ends at POS, return true or false based on the value of TYPE, which
  77 should be one of nil, `beg', `end', `none', or `all'.
  78 * If TYPE is nil, return true for an overlay starting at POS only if
  79   it is beg-sticky, and for one ending at POS only if it is end-sticky.
  80 * If TYPE is `beg', return true for any overlay starting at POS but
  81   false for any ending at POS.
  82 * If TYPE is `end', return true for any overlay ending at POS but
  83   false for any starting at POS.
  84 * If TYPE is `all', return true for any overlay starting or ending at POS.
  85 * If TYPE is `none' \(or any other value), return false for any
  86   overlay starting or ending at POS."
  87   (let ((beg (overlay-start ovl))
  88         (end (overlay-end ovl)))
  89     (cond ((and (= beg pos) (= end pos))
  90            ;; Do the Right Thing for zero-width overlays
  91            (case type
  92              ((nil) (and (overlay-get ovl 'beg-sticky)
  93                          (overlay-get ovl 'end-sticky)))
  94              ((none) nil)
  95              (t t)))
  96           ((= beg pos)
  97            (case type
  98              ((nil) (overlay-get ovl 'beg-sticky))
  99              ((beg all) t)
 100              (t nil)))
 101           ((= end pos)
 102            (case type
 103              ((nil) (overlay-get ovl 'end-sticky))
 104              ((end all) t)
 105              (t nil)))
 106           ((and (> end pos) (< beg pos))
 107            t))))
 108
 109 ;;; `mmm-overlays-in' has been retired as altogether too confusing a
 110 ;;; name, when what is really meant is one of the following three:
 111
 112 (defun mmm-overlays-containing (start stop)
 113   "Return all MMM overlays containing the region START to STOP.
 114 The overlays are returned in order of decreasing priority.  No
 115 attention is paid to stickiness."
 116   (mmm-sort-overlays
 117    (remove-if-not
 118     #'(lambda (ovl)
 119         (and (overlay-get ovl 'mmm)
 120              (<= (overlay-start ovl) start)
 121              (>= (overlay-end ovl) stop)))
 122     (overlays-in (max start (point-min))
 123                  (min stop (point-max))))))
 124
 125 (defun mmm-overlays-contained-in (start stop)
 126   "Return all MMM overlays entirely contained in START to STOP.
 127 The overlays are returned in order of decreasing priority.  No
 128 attention is paid to stickiness."
 129   (mmm-sort-overlays
 130    (remove-if-not
 131     #'(lambda (ovl)
 132         (and (overlay-get ovl 'mmm)
 133              (>= (overlay-start ovl) start)
 134              (<= (overlay-end ovl) stop)))
 135     (overlays-in (max start (point-min))
 136                  (min stop (point-max))))))
 137
 138 (defun mmm-overlays-overlapping (start stop)
 139   "Return all MMM overlays overlapping the region START to STOP.
 140 The overlays are returned in order of decreasing priority.  No
 141 attention is paid to stickiness."
 142   (mmm-sort-overlays
 143    (remove-if-not
 144     #'(lambda (ovl)
 145         (overlay-get ovl 'mmm))
 146     (overlays-in (max start (point-min))
 147                  (min stop (point-max))))))
 148
 149 (defun mmm-sort-overlays (overlays)
 150   "Sort OVERLAYS in order of decreasing priority."
 151   (sort (copy-list overlays)
 152         #'(lambda (x y) (> (or (overlay-get x 'priority) 0)
 153                            (or (overlay-get y 'priority) 0)))))
 154
 155 ;;}}}
 156 ;;{{{ Current Submode
 157
 158 (defvar mmm-current-overlay nil
 159   "What submode region overlay we think we are currently in.
 160 May be out of date; call `mmm-update-current-submode' to correct it.")
 161 (make-variable-buffer-local 'mmm-current-overlay)
 162
 163 (defvar mmm-previous-overlay nil
 164   "What submode region overlay we were in just before this one.
 165 Set by `mmm-update-current-submode'.")
 166 (make-variable-buffer-local 'mmm-previous-overlay)
 167
 168 (defvar mmm-current-submode nil
 169   "What submode we think we are currently in.
 170 May be out of date; call `mmm-update-current-submode' to correct it.")
 171 (make-variable-buffer-local 'mmm-current-submode)
 172
 173 (defvar mmm-previous-submode nil
 174   "What submode we were in just before this one.
 175 Set by `mmm-update-current-submode'.")
 176 (make-variable-buffer-local 'mmm-previous-submode)
 177
 178 (defun mmm-update-current-submode (&optional pos)
 179   "Update current and previous position variables to POS, or point.
 180 Return non-nil if the current region changed.
 181
 182 Also deletes overlays that ought to evaporate because their delimiters
 183 have disappeared."
 184   (mapc #'delete-overlay
 185         (remove-if #'(lambda (ovl)
 186                        (or (not (eq (overlay-get ovl 'mmm-evap) 'front))
 187                            (overlay-buffer (overlay-get ovl 'front))))
 188                    (mmm-overlays-at pos)))
 189   (let ((ovl (mmm-overlay-at pos)))
 190     (if (eq ovl mmm-current-overlay)
 191         nil
 192       (setq mmm-previous-overlay mmm-current-overlay
 193             mmm-previous-submode mmm-current-submode)
 194       (setq mmm-current-overlay ovl
 195             mmm-current-submode (if ovl (overlay-get ovl 'mmm-mode)))
 196       t)))
 197
 198 ;; This function is, I think, mostly for hacking font-lock.
 199 (defun mmm-set-current-submode (mode &optional pos)
 200   "Set the current submode to MODE and the current region to whatever
 201 region of that mode is present at POS, or nil if none."
 202   (setq mmm-previous-overlay mmm-current-overlay
 203         mmm-previous-submode mmm-current-submode)
 204   (setq mmm-current-submode mode
 205         mmm-current-overlay
 206         (find-if #'(lambda (ovl)
 207                      (eq (overlay-get ovl 'mmm-mode) mode))
 208                  (mmm-overlays-at (or pos (point)) 'all))))
 209
 210 (defun mmm-submode-at (&optional pos type)
 211   "Return the submode at POS \(or point), or NIL if none.
 212 See `mmm-included-p' for values of TYPE."
 213   (let ((ovl (mmm-overlay-at pos type)))
 214     (if ovl (overlay-get ovl 'mmm-mode))))
 215
 216 ;;}}}
 217 ;;{{{ Delimiter Matching and Boundaries
 218
 219 (defun mmm-match-front (ovl)
 220   "Return non-nil if the front delimiter of OVL matches as it should.
 221 Sets the match data to the front delimiter, if it is a regexp.
 222 Otherwise, calls it as a function with point at the beginning of the
 223 front delimiter overlay \(i.e. where the front delimiter ought to
 224 start) and one argument being the region overlay. The function should
 225 return non-nil if the front delimiter matches correctly, and set the
 226 match data appropriately."
 227   (let* ((front-ovl (overlay-get ovl 'front))
 228          (front (if front-ovl (overlay-get front-ovl 'match))))
 229     (when front
 230       (save-excursion
 231         (goto-char (overlay-start front-ovl))
 232         (if (stringp front)
 233             ;; It's a regexp
 234             (looking-at front)
 235           ;; It's a function
 236           (funcall front ovl))))))
 237
 238 (defun mmm-match-back (ovl)
 239   "Return non-nil if the back delimiter of OVL matches as it should.
 240 Sets the match data to the back delimiter, if it is a regexp.
 241 Otherwise, calls it as a function with point at the beginning of the
 242 back delimiter overlay \(i.e. where the back delimiter ought to start)
 243 and one argument being the region overlay. The function should return
 244 non-nil if the back delimiter matches correctly, and set the match
 245 data appropriately."
 246   (let* ((back-ovl (overlay-get ovl 'back))
 247          (back (if back-ovl (overlay-get back-ovl 'match))))
 248     (when back
 249       (save-excursion
 250         (goto-char (overlay-start back-ovl))
 251         (if (stringp back)
 252             ;; It's a regexp
 253             (looking-at back)
 254           ;; It's a function
 255           (funcall back ovl))))))
 256
 257 (defun mmm-front-start (ovl)
 258   "Return the position at which the front delimiter of OVL starts."
 259   (let ((front (overlay-get ovl 'front)))
 260     ;; Overlays which have evaporated become "overlays in no buffer"
 261     (if (and front (overlay-buffer front))
 262         (overlay-start front)
 263       (overlay-start ovl))))
 264
 265 (defun mmm-back-end (ovl)
 266   "Return the position at which the back delimiter of OVL ends."
 267   (let ((back (overlay-get ovl 'back)))
 268     ;; Overlays which have evaporated become "overlays in no buffer"
 269     (if (and back (overlay-buffer back))
 270         (overlay-end back)
 271       (overlay-end ovl))))
 272
 273 ;;}}}
 274
 275 ;; CREATION & DELETION
 276 ;;{{{ Make Submode Regions
 277
 278 (defun mmm-valid-submode-region (submode beg end)
 279   "Check if the region between BEG and END is valid for SUBMODE.
 280 This region must be entirely contained within zero or more existing
 281 submode regions, none of which start or end inside it, and it must be
 282 a valid child of the highest-priority of those regions, if any.
 283 Signals errors, returns `t' if no error."
 284   ;; First check if the placement is valid.  Every existing region
 285   ;; that overlaps this one must contain it in its entirety.
 286   (let ((violators (set-difference
 287                     (mmm-overlays-overlapping beg end)
 288                     (mmm-overlays-containing beg end))))
 289     (if violators
 290         (signal 'mmm-subregion-invalid-placement
 291                 violators)))
 292   ;; Now check if it is inside a valid parent
 293   (let ((parent-mode (mmm-submode-at beg 'beg)))
 294     (and parent-mode
 295          ;; TODO: Actually check parents here.  For present purposes,
 296          ;; we just make sure we aren't putting a submode inside one
 297          ;; of the same type.  Actually, what we should really be
 298          ;; doing is checking classes/names of regions, not just the
 299          ;; submodes.
 300          (eq submode parent-mode)
 301          (signal 'mmm-subregion-invalid-parent
 302                  (list parent-mode))))
 303   t)
 304
 305 (defun* mmm-make-region
 306     (submode beg end &key face
 307              front back (evaporation 'front)
 308              delimiter-mode front-face back-face
 309              display-name
 310              (match-front "") (match-back "")
 311              (beg-sticky t) (end-sticky t)
 312              name creation-hook
 313              )
 314   "Make a submode region from BEG to END of SUBMODE.
 315
 316 BEG and END are buffer positions or markers with BEG <= END \(although
 317 see EVAPORATION below).  SUBMODE is a major mode function or a valid
 318 argument to `mmm-modename->function'.  FACE is a valid display face.
 319
 320 FRONT and BACK specify the positions of the front and back delimiters
 321 for this region, if any.  If FRONT is a buffer position or marker, the
 322 front delimiter runs from it to BEG.  FRONT can also be a two-element
 323 list \(FRONT-BEG FRONT-END) specifying the exact position of the front
 324 delimiter.  One must have FRONT-BEG < FRONT-END <= BEG.
 325
 326 Similarly, BACK may be a buffer position or marker, in which case the
 327 back delimiter runs from END to BACK.  BACK can also be a two-element
 328 list \(BACK-BEG BACK-END) specifying the exact position, in which case
 329 we must have END <= BACK-BEG < BACK-END.
 330
 331 EVAPORATION specifies under what conditions this submode region should
 332 disappear.
 333 * If `nil', the region never disappears.  This can cause serious
 334   problems when using cut-and-paste and is not recommended.
 335 * If the value is t, the region disappears whenever it has zero
 336   length.  This is recommended for manually created regions used for
 337   temporary editing convenience.
 338 * If the value is `front', the region will disappear whenever the text
 339   in its front delimiter disappears, that is, whenever the overlay
 340   which marks its front delimiter has zero width.
 341 The default value is `front'.  However, if the parameter FRONT is nil,
 342 then this makes no sense, so the default becomes `t'.  Note that if
 343 EVAPORATION is `t', then an error is signalled if BEG = END.
 344
 345 MATCH-FRONT \(resp. MATCH-BACK) is a regexp or function to match the
 346 correct delimiters, see `mmm-match-front' \(resp. `mmm-match-back').
 347 It is ignored if FRONT \(resp. BACK) is nil.  At present these are not
 348 used much.
 349
 350 DELIMITER-MODE specifies the major mode to use for delimiter regions.
 351 A `nil' value means they remain in the primary mode.
 352
 353 FACE, FRONT-FACE, and BACK-FACE, are faces to use for the region, the
 354 front delimiter, and the back delimiter, respectively, under high
 355 decoration \(see `mmm-submode-decoration-level').
 356
 357 BEG-STICKY and END-STICKY determine whether the front and back of the
 358 region, respectively, are sticky with respect to new insertion.  The
 359 default is yes.
 360
 361 NAME is a string giving the \"name\" of this submode region.  Submode
 362 regions with the same name are considered part of the same code
 363 fragment and formatted accordingly.
 364
 365 DISPLAY-NAME is a string to display in the mode line when point is in
 366 this submode region.  If nil or not given, the name associated with
 367 SUBMODE is used.  In delimiter regions, \"--\" is shown.
 368
 369 CREATION-HOOK should be a function to run after the region is created,
 370 with point at the start of the new region."
 371   ;; Check placement of region and delimiters
 372   (unless (if (eq evaporation t)
 373             (< beg end)
 374           (<= beg end))
 375     (signal 'mmm-subregion-invalid-placement (list beg end)))
 376   (when front
 377     (unless (listp front)
 378       (setq front (list front beg)))
 379     (unless (and (< (car front) (cadr front))
 380                  (<= (cadr front) beg))
 381       (signal 'mmm-subregion-invalid-placement front)))
 382   (when back
 383     (unless (listp back)
 384       (setq back (list end back)))
 385     (unless (and (< (car back) (cadr back))
 386                  (<= end (car back)))
 387       (signal 'mmm-subregion-invalid-placement back)))
 388   (setq submode (mmm-modename->function submode))
 389   ;; Check embedding in existing regions
 390   (mmm-valid-submode-region submode beg end)
 391   (mmm-mode-on)
 392   (when submode
 393     (mmm-update-mode-info submode))
 394   (and (not front) (eq evaporation 'front) (setq evaporation t))
 395   (let ((region-ovl
 396          (mmm-make-overlay submode beg end name face beg-sticky end-sticky
 397                            (or (eq evaporation t) nil) display-name)))
 398     ;; Save evaporation type for checking later
 399     (overlay-put region-ovl 'mmm-evap evaporation)
 400     ;; Calculate priority to supersede anything already there.
 401     (overlay-put region-ovl 'priority (length (mmm-overlays-at beg)))
 402     ;; Make overlays for the delimiters, with appropriate pointers.
 403     (when front
 404       (let ((front-ovl
 405              (mmm-make-overlay delimiter-mode (car front) (cadr front)
 406                                nil front-face nil nil t "--" t)))
 407         (overlay-put region-ovl 'front front-ovl)
 408         (overlay-put front-ovl 'region region-ovl)
 409         (overlay-put front-ovl 'match match-front)))
 410     (when back
 411       (let ((back-ovl
 412              (mmm-make-overlay delimiter-mode (car back) (cadr back)
 413                                nil back-face nil nil t "--" t)))
 414         (overlay-put region-ovl 'back back-ovl)
 415         (overlay-put back-ovl 'region region-ovl)
 416         (overlay-put back-ovl 'match match-back)))
 417     ;; Update everything and run all the hooks
 418     (mmm-save-all
 419      (goto-char (overlay-start region-ovl))
 420      (mmm-set-current-submode submode)
 421      (mmm-set-local-variables submode)
 422      (mmm-run-submode-hook submode)
 423      (when creation-hook
 424        (funcall creation-hook))
 425      (mmm-save-changed-local-variables region-ovl submode))
 426     (setq mmm-previous-submode submode
 427           mmm-previous-overlay region-ovl)
 428     (mmm-update-submode-region)
 429     region-ovl))
 430
 431 (defun mmm-make-overlay (submode beg end name face beg-sticky end-sticky evap
 432                                  &optional display-name delim)
 433   "Internal function to make submode overlays.
 434 Does not handle delimiters.  Use `mmm-make-region'."
 435   (let ((ovl (make-overlay beg end nil (not beg-sticky) end-sticky)))
 436     (mapc
 437      #'(lambda (pair) (overlay-put ovl (car pair) (cadr pair)))
 438      `((mmm t)                          ; Mark all submode overlays
 439        (mmm-mode ,submode)
 440        ,@(if delim '((delim t)) nil)
 441        (mmm-local-variables
 442         ;; Have to be careful to make new list structure here
 443         ,(list* (list 'font-lock-cache-state nil)
 444                 (list 'font-lock-cache-position (make-marker))
 445                 (copy-tree
 446                  (cdr (assq submode mmm-region-saved-locals-defaults)))))
 447        (name ,name)
 448        (display-name ,display-name)
 449        ;; Need to save these, because there's no way of accessing an
 450        ;; overlay's official "front-advance" parameter once it's created.
 451        (beg-sticky ,beg-sticky)
 452        (end-sticky ,end-sticky)
 453        ;; These have special meaning to Emacs
 454        (,mmm-evaporate-property ,evap)
 455        (face ,(mmm-get-face face submode delim))
 456        ))
 457     ovl))
 458
 459 (defun mmm-get-face (face submode &optional delim)
 460   (cond ((= mmm-submode-decoration-level 0) nil)
 461         ((and (= mmm-submode-decoration-level 2) face) face)
 462         (delim 'mmm-delimiter-face)
 463         (submode 'mmm-default-submode-face)))
 464
 465 ;;}}}
 466 ;;{{{ Clear Overlays
 467
 468 ;; See also `mmm-clear-current-region'.
 469
 470 (defun mmm-clear-overlays (&optional start stop strict)
 471   "Clears all MMM overlays overlapping START and STOP.
 472 If STRICT, only clear those entirely included in that region."
 473   (mapcar #'delete-overlay
 474           (if strict
 475               (mmm-overlays-contained-in (or start (point-min))
 476                                          (or stop (point-max)))
 477             (mmm-overlays-overlapping (or start (point-min))
 478                                       (or stop (point-max)))))
 479   (mmm-update-submode-region))
 480
 481 ;;}}}
 482
 483 ;; BASIC UPDATING
 484 ;;{{{ Submode Info
 485
 486 (defun mmm-update-mode-info (mode &optional force)
 487   "Save the global-saved and buffer-saved variables for MODE.
 488 Global saving is done on properties of the symbol MODE and buffer
 489 saving in `mmm-buffer-saved-locals'.  This function must be called for
 490 both the dominant mode and all submodes, in each file.  Region-saved
 491 variables are initialized from `mmm-region-saved-locals-defaults',
 492 which is set here as well.  See `mmm-save-local-variables'.  If FORCE
 493 is non-nil, don't quit if the info is already there."
 494   (let ((buffer-entry (assq mode mmm-buffer-saved-locals))
 495         (region-entry (assq mode mmm-region-saved-locals-defaults))
 496         global-vars buffer-vars region-vars
 497         ;; kludge for XEmacs 20
 498         (html-helper-build-new-buffer nil))
 499     (unless (and (not force)
 500                  (get mode 'mmm-local-variables)
 501                  buffer-entry
 502                  region-entry)
 503       (save-excursion
 504         (let ((filename (buffer-file-name)))
 505           ;; On errors, the temporary buffers don't get deleted, so here
 506           ;; we get rid of any old ones that may be hanging around.
 507           (when (buffer-live-p (get-buffer mmm-temp-buffer-name))
 508             (save-excursion
 509               (set-buffer (get-buffer mmm-temp-buffer-name))
 510               (set-buffer-modified-p nil)
 511               (kill-buffer (current-buffer))))
 512           ;; Now make a new temporary buffer.
 513           (set-buffer (mmm-make-temp-buffer (current-buffer)
 514                                             mmm-temp-buffer-name))
 515           ;; Handle stupid modes that need the file name set
 516           (if (memq mode mmm-set-file-name-for-modes)
 517               (setq buffer-file-name filename)))
 518         (funcall mode)
 519         (when (featurep 'font-lock)
 520           ;; XEmacs doesn't have global-font-lock-mode (or rather, it
 521           ;; has nothing but global-font-lock-mode).
 522           (when (or mmm-xemacs
 523                     ;; Code copied from font-lock.el to detect when font-lock
 524                     ;; should be on via global-font-lock-mode.
 525                     (and (or font-lock-defaults
 526                              (assq major-mode font-lock-defaults-alist)
 527                              (assq major-mode font-lock-keywords-alist))
 528                          (or (eq font-lock-global-modes t)
 529                              (if (eq (car-safe font-lock-global-modes) 'not)
 530                                  (not (memq major-mode
 531                                             (cdr font-lock-global-modes)))
 532                                (memq major-mode font-lock-global-modes)))))
 533             ;; Don't actually fontify in the temp buffer, but note
 534             ;; that we should fontify when we use this mode.
 535             (put mode 'mmm-font-lock-mode t))
 536           ;; Get the font-lock variables
 537           (when mmm-font-lock-available-p
 538             ;; To fool `font-lock-add-keywords'
 539             (let ((font-lock-mode t))
 540               (mmm-set-font-lock-defaults)))
 541           ;; These can't be in the local variables list, because we
 542           ;; replace their actual values, but we want to use their
 543           ;; original values elsewhere.
 544           (unless (and mmm-xemacs (= emacs-major-version 20))
 545             ;; XEmacs 20 doesn't have this variable.  This effectively
 546             ;; prevents the MMM font-lock support from working, but we
 547             ;; just ignore it and go on, to prevent an error message.
 548             (put mode 'mmm-fontify-region-function
 549                  font-lock-fontify-region-function))
 550           (put mode 'mmm-beginning-of-syntax-function
 551                font-lock-beginning-of-syntax-function))
 552         ;; Get variables
 553         (setq global-vars (mmm-get-locals 'global)
 554               buffer-vars (mmm-get-locals 'buffer)
 555               region-vars (mmm-get-locals 'region))
 556         (put mode 'mmm-mode-name mode-name)
 557         (set-buffer-modified-p nil)
 558         (kill-buffer (current-buffer)))
 559       (put mode 'mmm-local-variables global-vars)
 560       (if buffer-entry
 561           (setcdr buffer-entry buffer-vars)
 562         (push (cons mode buffer-vars) mmm-buffer-saved-locals))
 563       (if region-entry
 564           (setcdr region-entry region-vars)
 565         (push (cons mode region-vars)
 566               mmm-region-saved-locals-defaults)))))
 567
 568 ;;}}}
 569 ;;{{{ Updating Hooks
 570
 571 (defun mmm-update-submode-region ()
 572   "Update all MMM properties correctly for the current position.
 573 This function and those it calls do the actual work of setting the
 574 different keymaps, syntax tables, local variables, etc. for submodes."
 575   (when (mmm-update-current-submode)
 576     (mmm-save-changed-local-variables mmm-previous-overlay
 577                                       mmm-previous-submode)
 578     (let ((mode (or mmm-current-submode mmm-primary-mode)))
 579       (mmm-update-mode-info mode)
 580       (mmm-set-local-variables mode)
 581       (mmm-enable-font-lock mode))
 582     (mmm-set-mode-line)
 583     (dolist (func (if mmm-current-overlay
 584                       (overlay-get mmm-current-overlay 'entry-hook)
 585                     mmm-primary-mode-entry-hook))
 586       (ignore-errors (funcall func)))))
 587
 588 (defun mmm-add-hooks ()
 589   (make-local-hook 'post-command-hook)
 590   (add-hook 'post-command-hook 'mmm-update-submode-region nil 'local))
 591
 592 (defun mmm-remove-hooks ()
 593   (remove-hook 'post-command-hook 'mmm-update-submode-region 'local))
 594
 595 ;;}}}
 596 ;;{{{ Local Variables
 597
 598 (defun mmm-get-local-variables-list (type mode)
 599   "Filter `mmm-save-local-variables' to match TYPE and MODE.
 600 Return a list \(VAR ...).  In some cases, VAR will be a cons cell
 601 \(GETTER . SETTER) -- see `mmm-save-local-variables'."
 602   (mapcan #'(lambda (element)
 603               (and (if (and (consp element)
 604                             (cdr element)
 605                             (cadr element))
 606                        (eq (cadr element) type)
 607                      (eq type 'global))
 608                    (if (and (consp element)
 609                             (cddr element)
 610                             (not (eq (caddr element) t)))
 611                        (if (functionp (caddr element))
 612                            (funcall (caddr element))
 613                          (member mode (caddr element)))
 614                      t)
 615                    (list (if (consp element) (car element) element))))
 616           mmm-save-local-variables))
 617
 618 (defun mmm-get-locals (type)
 619   "Get the local variables and values for TYPE from this buffer.
 620 Return \((VAR VALUE) ...).  In some cases, VAR will be of the form
 621 \(GETTER . SETTER) -- see `mmm-save-local-variables'."
 622   (mapcan #'(lambda (var)
 623               (if (consp var)
 624                   `((,var ,(funcall (car var))))
 625                 (and (boundp var)
 626                      ;; This seems logical, but screws things up.
 627                      ;;(local-variable-p var)
 628                      `((,var ,(symbol-value var))))))
 629           (mmm-get-local-variables-list type major-mode)))
 630
 631 (defun mmm-get-saved-local (mode var)
 632   "Get the value of the local variable VAR saved for MODE, if any."
 633   (cadr (assq var (mmm-get-saved-local-variables mode))))
 634
 635 (defun mmm-set-local-variables (mode)
 636   "Set all the local variables saved for MODE.
 637 Looks up both global, buffer, and region saves."
 638   (mapcar #'(lambda (var)
 639               ;; (car VAR) may be (GETTER . SETTER)
 640               (if (consp (car var))
 641                   (funcall (cdar var) (cadr var))
 642                 (make-local-variable (car var))
 643                 (set (car var) (cadr var))))
 644           (mmm-get-saved-local-variables mode)))
 645
 646 (defun mmm-get-saved-local-variables (mode)
 647   (append (get mode 'mmm-local-variables)
 648           (cdr (assq mode mmm-buffer-saved-locals))
 649           (let ((ovl (mmm-overlay-at (point))))
 650             (if ovl
 651                 (overlay-get ovl 'mmm-local-variables)
 652               mmm-region-saved-locals-for-dominant))))
 653
 654 (defun mmm-save-changed-local-variables (ovl mode)
 655   "Save by-buffer and by-region variables for OVL and MODE.
 656 Called when we move to a new submode region, with OVL and MODE the
 657 region and mode for the previous position."
 658   (let ((buffer-vars (cdr (assq (or mode mmm-primary-mode)
 659                                 mmm-buffer-saved-locals)))
 660         (region-vars (if ovl
 661                          (overlay-get ovl 'mmm-local-variables)
 662                        mmm-region-saved-locals-for-dominant))
 663         (set-local-value
 664          #'(lambda (var)
 665              (setcar (cdr var)
 666                      ;; (car VAR) may be (GETTER . SETTER)
 667                      (if (consp (car var))
 668                          (funcall (caar var))
 669                        (symbol-value (car var)))))))
 670     (mapc set-local-value buffer-vars)
 671     (mapc set-local-value region-vars)))
 672
 673 (defun mmm-clear-local-variables ()
 674   "Clear all buffer- and region-saved variables for current buffer."
 675   (setq mmm-buffer-saved-locals ()
 676         mmm-region-saved-locals-defaults ()
 677         mmm-region-saved-locals-for-dominant ()))
 678
 679 ;;}}}
 680
 681 ;; FONT LOCK
 682 ;;{{{ Enable Font Lock
 683
 684 (defun mmm-enable-font-lock (mode)
 685   "Turn on font lock if it is not already on and MODE enables it."
 686   (mmm-update-mode-info mode)
 687   (and mmm-font-lock-available-p
 688        (not font-lock-mode)
 689        (get mode 'mmm-font-lock-mode)
 690        (font-lock-mode 1)))
 691
 692 (defun mmm-update-font-lock-buffer ()
 693   "Turn on font lock iff any mode in the buffer enables it."
 694   (when mmm-font-lock-available-p
 695     (if (some #'(lambda (mode)
 696                   (get mode 'mmm-font-lock-mode))
 697               (cons mmm-primary-mode
 698                     (mapcar #'(lambda (ovl)
 699                                 (overlay-get ovl 'mmm-mode))
 700                             (mmm-overlays-overlapping
 701                              (point-min) (point-max)))))
 702         (font-lock-mode 1)
 703       (font-lock-mode 0))))
 704
 705 (defun mmm-refontify-maybe (&optional start stop)
 706   "Re-fontify from START to STOP, or entire buffer, if enabled."
 707   (and font-lock-mode
 708        (if (or start stop)
 709            (font-lock-fontify-region (or start (point-min))
 710                                      (or stop (point-max)))
 711          (font-lock-fontify-buffer))))
 712
 713 ;;}}}
 714 ;;{{{ Get Submode Regions
 715
 716 ;;; In theory, these are general functions that have nothing to do
 717 ;;; with font-lock, but they aren't used anywhere else, so we might as
 718 ;;; well have them close.
 719
 720 (defun mmm-submode-changes-in (start stop)
 721   "Return a list of all submode-change positions from START to STOP.
 722 The list is sorted in order of increasing buffer position."
 723   (sort (remove-duplicates
 724          (list* start stop
 725                 (mapcan #'(lambda (ovl)
 726                             `(,(overlay-start ovl)
 727                               ,(overlay-end ovl)))
 728                         (mmm-overlays-overlapping start stop))))
 729         #'<))
 730
 731 (defun mmm-regions-in (start stop)
 732   "Return a list of regions of the form (MODE BEG END) whose disjoint
 733 union covers the region from START to STOP, including delimiters."
 734   (let ((regions
 735          (maplist #'(lambda (pos-list)
 736                       (if (cdr pos-list)
 737                           (list (or (mmm-submode-at (car pos-list) 'beg)
 738                                     mmm-primary-mode)
 739                                 (car pos-list) (cadr pos-list))))
 740                   (mmm-submode-changes-in start stop))))
 741     (setcdr (last regions 2) nil)
 742     regions))
 743
 744
 745 (defun mmm-regions-alist (start stop)
 746   "Return a list of lists of the form \(MODE . REGIONS) where REGIONS
 747 is a list of elements of the form \(BEG END). The disjoint union all
 748 of the REGIONS covers START to STOP."
 749   (let ((regions (mmm-regions-in start stop)))
 750     (mapcar #'(lambda (mode)
 751                 (cons mode
 752                       (mapcan #'(lambda (region)
 753                                   (if (eq mode (car region))
 754                                       (list (cdr region))))
 755                               regions)))
 756             ;; All the modes
 757             (remove-duplicates (mapcar #'car regions)))))
 758
 759 ;;}}}
 760 ;;{{{ Fontify Regions
 761
 762 (defun mmm-fontify-region (start stop &optional loudly)
 763   "Fontify from START to STOP keeping track of submodes correctly."
 764   (when loudly
 765     (message "Fontifying %s with submode regions..." (buffer-name)))
 766   ;; Necessary to catch changes in font-lock cache state and position.
 767   (mmm-save-changed-local-variables
 768    mmm-current-overlay mmm-current-submode)
 769   ;; For some reason `font-lock-fontify-block' binds this to nil, thus
 770   ;; preventing `mmm-beginning-of-syntax' from doing The Right Thing.
 771   ;; I don't know why it does this, but let's undo it here.
 772   (let ((font-lock-beginning-of-syntax-function 'mmm-beginning-of-syntax))
 773     (mapc #'(lambda (elt)
 774                 (when (get (car elt) 'mmm-font-lock-mode)
 775                   (mmm-fontify-region-list (car elt) (cdr elt))))
 776             (mmm-regions-alist start stop)))
 777   ;; With jit-lock, this causes blips in the mode line and menus.
 778   ;; Shouldn't be necessary here, since it's in post-command-hook too.
 779   ;;(mmm-update-submode-region)
 780   (when loudly (message nil)))
 781
 782 (defun mmm-fontify-region-list (mode regions)
 783   "Fontify REGIONS, each like \(BEG END), in mode MODE."
 784   (save-excursion
 785     (let (;(major-mode mode)
 786           (func (get mode 'mmm-fontify-region-function)))
 787       (mapc #'(lambda (reg)
 788                   (goto-char (car reg))
 789                   ;; Here we do the same sort of thing that
 790                   ;; `mmm-update-submode-region' does, but we force it
 791                   ;; to use a specific mode, and don't save anything,
 792                   ;; fontify, or change the mode line.
 793                   (mmm-set-current-submode mode)
 794                   (mmm-set-local-variables mode)
 795                   (funcall func (car reg) (cadr reg) nil)
 796                   ;; Catch changes in font-lock cache.
 797                   (mmm-save-changed-local-variables
 798                    mmm-current-overlay mmm-current-submode))
 799               regions))))
 800
 801 ;;}}}
 802 ;;{{{ Beginning of Syntax
 803
 804 (defun mmm-beginning-of-syntax ()
 805   (goto-char
 806    (let ((ovl (mmm-overlay-at (point)))
 807          (func (get (or mmm-current-submode mmm-primary-mode)
 808                     'mmm-beginning-of-syntax-function)))
 809      (max (if ovl (overlay-start ovl) (point-min))
 810           (if func (progn (funcall func) (point)) (point-min))
 811           (point-min)))))
 812
 813 ;;}}}
 814
 815 (provide 'mmm-region)
 816
 817 ;;; mmm-region.el ends here