[appearance] Update source of `org-src-font-lock-fontify-block'.

1 files changed, 41 insertions, 32 deletions

diff --git a/lisp/appearance.el b/lisp/appearance.el
index 2d365f7..c0ff65c 100644
--- a/lisp/appearance.el
+++ b/lisp/appearance.el
@@ -40,40 +40,49 @@
   "Fontify code block.
 This function is called by emacs automatic fontification, as long
 as `org-src-fontify-natively' is non-nil."
-  (let ((lang-mode (org-src--get-lang-mode lang)))
+  (let ((lang-mode (org-src-get-lang-mode lang)))
     (when (fboundp lang-mode)
       (let ((string (buffer-substring-no-properties start end))
-        (modified (buffer-modified-p))
-        (org-buffer (current-buffer)) pos next)
-    (remove-text-properties start end '(face nil))
-    (with-current-buffer
-        (get-buffer-create
-         (concat " org-src-fontification:" (symbol-name lang-mode)))
-      (delete-region (point-min) (point-max))
-      (insert string " ") ;; so there's a final property change
-      (unless (eq major-mode lang-mode) (funcall lang-mode))
-      ;; Avoid `font-lock-ensure', which does not display fonts in
-      ;; source block.
-      (font-lock-fontify-buffer)
-      (setq pos (point-min))
-      (while (setq next (next-single-property-change pos 'face))
-        (put-text-property
-         (+ start (1- pos)) (1- (+ start next)) 'face
-         (get-text-property pos 'face) org-buffer)
-        (setq pos next))
-      ;; Addition: also copy 'composition info for prettified symbols
-      (setq pos (point-min))
-      (while (setq next (next-single-property-change pos 'composition))
-        (put-text-property
-         (+ start (1- pos)) (1- (+ start next)) 'composition
-         (get-text-property pos 'composition) org-buffer)
-        (setq pos next))
-      ;; End addition
-      )
-    (add-text-properties
-     start end
-     '(font-lock-fontified t fontified t font-lock-multiline t))
-    (set-buffer-modified-p modified)))))
+	        (modified (buffer-modified-p))
+	        (org-buffer (current-buffer)))
+	    (remove-text-properties start end '(face nil))
+	    (with-current-buffer
+	        (get-buffer-create
+	         (format " *org-src-fontification:%s*" lang-mode))
+	      (let ((inhibit-modification-hooks nil))
+	        (erase-buffer)
+	        ;; Add string and a final space to ensure property change.
+	        (insert string " "))
+	      (unless (eq major-mode lang-mode) (funcall lang-mode))
+	      (org-font-lock-ensure)
+	      (let ((pos (point-min)) next)
+	        (while (setq next (next-property-change pos))
+	          ;; Handle additional properties from font-lock, so as to
+	          ;; preserve, e.g., composition.
+	          (dolist (prop (cons 'face font-lock-extra-managed-props))
+		        (let ((new-prop (get-text-property pos prop)))
+		          (put-text-property
+		           (+ start (1- pos)) (1- (+ start next)) prop new-prop
+		           org-buffer)))
+	          (setq pos next))
+            ;; Addition: also copy 'composition info for prettified symbols
+            (setq pos (point-min))
+            (while (setq next (next-single-property-change pos 'composition))
+              (put-text-property
+               (+ start (1- pos)) (1- (+ start next)) 'composition
+               (get-text-property pos 'composition) org-buffer)
+              (setq pos next)))
+          ;; End addition
+          )
+	    ;; Add Org faces.
+	    (let ((src-face (nth 1 (assoc-string lang org-src-block-faces t))))
+          (when (or (facep src-face) (listp src-face))
+            (font-lock-append-text-property start end 'face src-face))
+	      (font-lock-append-text-property start end 'face 'org-block))
+	    (add-text-properties
+	     start end
+	     '(font-lock-fontified t fontified t font-lock-multiline t))
+	    (set-buffer-modified-p modified)))))
 
 ;; Although I'm usually not a fan of treating non-printable ASCII like this, the
 ;; lines act as sort more of a cue for me to use <C-x [> and <C-x ]> than a