Re: [PATCH] Re: Algorithm in electric-pair--unbalanced-strings-p unsuitable for CC Mode

[Alan Mackenzie]

Hello, João.

On Tue, Jul 09, 2019 at 11:54:39 +0100, João Távora wrote:
> On Tue, Jul 9, 2019 at 10:52 AM Alan Mackenzie <address@hidden> wrote:

> > Hello, João.

> > > > many, many years. Depending on how it is implemented (certainly how
> > > > Alan implemented it) it breaks things in Emacs core and
> > > > third-party code.
> > Can we perhaps keep the disparagement a bit more muted, please?


> How can this be disparagement? It's a simple statement of fact.

It is an extreme interpretation of somewhat controversial facts.

> If you didn't break things, what did you fix and what are you fixing?

I'm fixing electric-pair-mode, and I'm adding a feature to CC Mode
specially for you, because you've asked for it so insistently.  :-)

[ .... ]

So, although the enhancement is not yet bug free, I'm supplying you with
the following patch, with the request you undo your unofficial
modifications to CC Mode and try out the patch.  It is not 100% bug free,
but might be close to it.

It should allow you to do syntactic operations on two disjoint "s, while
at the same time preserving CC Mode's fontification strategy.

You may have less justification for complaining after trying this out.
No apologies for that.  ;-)



diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index a43f1ac72d..ad3cb9c125 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -406,6 +406,25 @@ lookup-syntax-properties
         (forward-sexp)
         (= (point) (+ 4 (point-min)))))))
 
+(defmacro c-is-escaped (pos)
+  ;; Are there an odd number of backslashes before POS?
+  `(save-excursion
+     (goto-char ,pos)
+     (not (zerop (logand (skip-chars-backward "\\\\") 1)))))
+
+(defmacro c-will-be-escaped (pos beg end)
+  ;; Will the character after POS be escaped after the removal of (BEG END)?
+  ;; It is assumed that (>= POS END).
+  `(save-excursion
+     (let ((-end- ,end)
+          count)
+       (goto-char ,pos)
+       (setq count (skip-chars-backward "\\\\" -end-))
+       (when (eq (point) -end-)
+        (goto-char ,beg)
+        (setq count (+ count (skip-chars-backward "\\\\"))))
+       (not (zerop (logand count 1))))))
+
 (defvar c-use-extents)
 
 (defmacro c-next-single-property-change (position prop &optional object limit)
@@ -1019,6 +1038,14 @@ c-major-mode-is
 ;; properties set on a single character and that never spread to any
 ;; other characters.
 
+(defmacro c-put-syn-tab (pos value)
+  ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to
+  ;; VALUE (which should not be nil).
+  `(let ((-pos- ,pos)
+        (-value- ,value))
+     (c-put-char-property -pos- 'syntax-table -value-)
+     (c-put-char-property -pos- 'c-fl-syn-tab -value-)))
+
 (eval-and-compile
   ;; Constant used at compile time to decide whether or not to use
   ;; XEmacs extents.  Check all the extent functions we'll use since
@@ -1146,6 +1173,12 @@ c-clear-char-property
         ;; Emacs < 21.
         `(c-clear-char-property-fun ,pos ',property))))
 
+(defmacro c-clear-syn-tab (pos)
+  ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS.
+  `(let ((-pos- ,pos))
+     (c-clear-char-property -pos- 'syntax-table)
+     (c-clear-char-property -pos- 'c-fl-syn-tab)))
+
 (defmacro c-min-property-position (from to property)
   ;; Return the first position in the range [FROM to) where the text property
   ;; PROPERTY is set, or `most-positive-fixnum' if there is no such position.
@@ -1381,6 +1414,29 @@ c-put-char-properties-on-char
             `((setq c-syntax-table-hwm (min c-syntax-table-hwm (point)))))
         (c-put-char-property (point) ,property ,value)
         (forward-char)))))
+
+(defmacro c-with-extended-string-fences (beg end &rest body)
+  ;; If needed, extend the region with "mirrored" c-fl-syn-tab properties to
+  ;; contain the region (BEG END), then evaluate BODY.  If this mirrored
+  ;; region was initially empty, restore it afterwards.
+  `(let ((-beg- ,beg)
+        (-end- ,end)
+        )
+     (cond
+      ((null c-fl-syn-tab-region)
+       (unwind-protect
+          (progn
+            (c-restore-string-fences -beg- -end-)
+            ,@body)
+        (c-clear-string-fences)))
+      ((and (>= -beg- (car c-fl-syn-tab-region))
+           (<= -end- (cdr c-fl-syn-tab-region)))
+       ,@body)
+      (t                               ; Crudely extend the mirrored region.
+       (setq -beg- (min -beg- (car c-fl-syn-tab-region))
+            -end- (max -end- (cdr c-fl-syn-tab-region)))
+       (c-restore-string-fences -beg- -end-)
+       ,@body))))
 
 ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text.
 ;; For our purposes, these are characterized by being possible to
@@ -1463,6 +1519,7 @@ c-clear-char-property-with-value
 (def-edebug-spec c-clear-char-property-with-value-on-char t)
 (def-edebug-spec c-put-char-properties-on-char t)
 (def-edebug-spec c-clear-char-properties t)
+(def-edebug-spec c-with-extended-string-fences (form form body))
 (def-edebug-spec c-put-overlay t)
 (def-edebug-spec c-delete-overlay t)
 (def-edebug-spec c-mark-<-as-paren t)
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index 40a3b72f6a..656dfd126c 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -155,6 +155,9 @@
 (defvar c-doc-line-join-re)
 (defvar c-doc-bright-comment-start-re)
 (defvar c-doc-line-join-end-ch)
+(defvar c-fl-syn-tab-region)
+(cc-bytecomp-defun c-clear-string-fences)
+(cc-bytecomp-defun c-restore-string-fences)
 
 
 ;; Make declarations for all the `c-lang-defvar' variables in cc-langs.
@@ -2816,7 +2819,14 @@ c-semi-pp-to-literal
                                 c-block-comment-awkward-chars)))
                 (and (nth 4 s) (nth 7 s) ; Line comment
                      (not (memq (char-before here) '(?\\ ?\n)))))))
-           (setq s (parse-partial-sexp pos here nil nil s)))
+;;;; OLD STOUGH, 2019-07-09
+           ;; (setq s (parse-partial-sexp pos here nil nil s))
+;;;; NEW STOUGH, 2019-07-09
+           (c-with-extended-string-fences
+            pos here
+            (setq s (parse-partial-sexp pos here nil nil s)))
+;;;; END OF NEW STOUGH
+                                                           )
          (when (not (eq near-pos here))
            (c-semi-put-near-cache-entry here s))
          (cond
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index 98b8385fcc..395a6b1a9d 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -181,6 +181,7 @@ c-leave-cc-mode-mode
       (c-save-buffer-state ()
        (c-clear-char-properties (point-min) (point-max) 'category)
        (c-clear-char-properties (point-min) (point-max) 'syntax-table)
+       (c-clear-char-properties (point-min) (point-max) 'c-fl-syn-tab)
        (c-clear-char-properties (point-min) (point-max) 'c-is-sws)
        (c-clear-char-properties (point-min) (point-max) 'c-in-sws)
        (c-clear-char-properties (point-min) (point-max) 'c-type)
@@ -1016,6 +1017,7 @@ c-depropertize-new-text
   (c-save-buffer-state ()
     (when (> end beg)
       (c-clear-char-properties beg end 'syntax-table)
+      (c-clear-char-properties beg end 'c-fl-syn-tab)
       (c-clear-char-properties beg end 'category)
       (c-clear-char-properties beg end 'c-is-sws)
       (c-clear-char-properties beg end 'c-in-sws)
@@ -1205,6 +1207,43 @@ c-multiline-string-check-final-quote
        (c-put-char-property (1- (point)) 'syntax-table '(15)))
        (t nil)))))
 
+(defvar c-fl-syn-tab-region nil)
+  ;; Non-nil when a `c-restore-string-fences' is "in force".  It's value is a
+  ;; cons of the BEG and END of the region currently "mirroring" the
+  ;; c-fl-syn-tab properties as syntax-table properties.
+
+(defun c-clear-string-fences ()
+  ;; Clear any syntax-table text properties in the region defined by
+  ;; `c-fl-syn-tab-region' which are "mirrored" by c-fl-syn-tab text
+  ;; properties.
+  (when c-fl-syn-tab-region
+    (let ((pos (car c-fl-syn-tab-region))
+         (end (cdr c-fl-syn-tab-region)))
+      (while
+         (and
+          (< pos end)
+          (setq pos
+                (c-min-property-position pos end 'c-fl-syn-tab))
+          (< pos end))
+       (c-clear-char-property pos 'syntax-table)
+       (setq pos (1+ pos)))
+      (setq c-fl-syn-tab-region nil))))
+
+(defun c-restore-string-fences (beg end)
+  ;; Restore any syntax-table text properties in the region (BEG END) which
+  ;; are "mirrored" by c-fl-syn-tab text properties.
+  (let ((pos beg))
+    (while
+       (and
+        (< pos end)
+        (setq pos
+              (c-min-property-position pos end 'c-fl-syn-tab))
+        (< pos end))
+      (c-put-char-property pos 'syntax-table
+                          (c-get-char-property pos 'c-fl-syn-tab))
+      (setq pos (1+ pos)))
+    (setq c-fl-syn-tab-region (cons beg end))))
+
 (defvar c-bc-changed-stringiness nil)
 ;; Non-nil when, in a before-change function, the deletion of a range of text
 ;; will change the "stringiness" of the subsequent text.  Only used when
@@ -1261,7 +1300,7 @@ c-before-change-check-unbalanced-strings
                       "\"\\|\\s|")
                     (point-max) t t)
                    (progn
-                     (c-clear-char-property (1- (point)) 'syntax-table)
+                     (c-clear-syn-tab (1- (point)))
                      (c-truncate-lit-pos-cache (1- (point)))
                      (not (memq (char-before) c-string-delims)))))
               (memq (char-before) c-string-delims))
@@ -1291,10 +1330,8 @@ c-before-change-check-unbalanced-strings
          (cond
           ;; Are we escaping a newline by deleting stuff between \ and \n?
           ((and (> end beg)
-                (progn
-                  (goto-char end)
-                  (eq (logand (skip-chars-backward "\\\\" beg) 1) 1)))
-           (c-clear-char-property end 'syntax-table)
+                (c-will-be-escaped end beg end))
+           (c-clear-syn-tab end)
            (c-truncate-lit-pos-cache end)
            (goto-char (1+ end)))
           ;; Are we unescaping a newline by inserting stuff between \ and \n?
@@ -1317,15 +1354,15 @@ c-before-change-check-unbalanced-strings
              (let ((eoll-1 (point)))
                (forward-char)
                (backward-sexp)
-               (c-clear-char-property eoll-1 'syntax-table)
-               (c-clear-char-property (point) 'syntax-table)
+               (c-clear-syn-tab eoll-1)
+               (c-clear-syn-tab (point))
                (c-truncate-lit-pos-cache (point)))
            ;; Opening " at EOB.
-           (c-clear-char-property (1- (point)) 'syntax-table))
+           (c-clear-syn-tab (1- (point))))
        (when (and (c-search-backward-char-property 'syntax-table '(15) 
c-new-BEG)
                   (memq (char-after) c-string-delims)) ; Ignore an 
unterminated raw string's (.
          ;; Opening " on last line of text (without EOL).
-         (c-clear-char-property (point) 'syntax-table)
+         (c-clear-syn-tab (point))
          (c-truncate-lit-pos-cache (point))
          (setq c-new-BEG (min c-new-BEG (point))))))
 
@@ -1334,7 +1371,7 @@ c-before-change-check-unbalanced-strings
            (and
             (c-search-backward-char-property 'syntax-table '(15) c-new-BEG)
             (memq (char-after) c-string-delims))
-         (c-clear-char-property (point) 'syntax-table)
+         (c-clear-syn-tab (point))
          (c-truncate-lit-pos-cache (point)))))
 
     (unless 
@@ -1346,13 +1383,13 @@ c-before-change-check-unbalanced-strings
                 (not (c-characterp c-multiline-string-start-char))))
       (when (and (eq end-literal-type 'string)
                 (not (eq (char-before (cdr end-limits)) ?\()))
-       (c-clear-char-property (1- (cdr end-limits)) 'syntax-table)
+       (c-clear-syn-tab (1- (cdr end-limits)))
        (c-truncate-lit-pos-cache (1- (cdr end-limits)))
        (setq c-new-END (max c-new-END (cdr end-limits))))
 
       (when (and (eq beg-literal-type 'string)
                 (memq (char-after (car beg-limits)) c-string-delims))
-       (c-clear-char-property (car beg-limits) 'syntax-table)
+       (c-clear-syn-tab (car beg-limits))
        (c-truncate-lit-pos-cache (car beg-limits))
        (setq c-new-BEG (min c-new-BEG (car beg-limits)))))))
 
@@ -1375,7 +1412,7 @@ c-after-change-mark-abnormal-strings
           end-literal-limits end-literal-type)
        (when (and (eq beg-literal-type 'string)
                   (c-get-char-property (car beg-literal-limits) 'syntax-table))
-         (c-clear-char-property (car beg-literal-limits) 'syntax-table)
+         (c-clear-syn-tab (car beg-literal-limits))
          (setq c-bc-changed-stringiness (not c-bc-changed-stringiness)))
        (setq end-literal-limits (progn (goto-char end) (c-literal-limits))
              end-literal-type (c-literal-type end-literal-limits))
@@ -1456,13 +1493,13 @@ c-after-change-mark-abnormal-strings
            (looking-at (cdr (assq (char-before) c-string-innards-re-alist))))
          (cond
           ((memq (char-after (match-end 0)) '(?\n ?\r))
-           (c-put-char-property (1- (point)) 'syntax-table '(15))
-           (c-put-char-property (match-end 0) 'syntax-table '(15))
+           (c-put-syn-tab (1- (point)) '(15))
+           (c-put-syn-tab (match-end 0) '(15))
            (setq c-new-BEG (min c-new-BEG (point))
                  c-new-END (max c-new-END (match-end 0))))
           ((or (eq (match-end 0) (point-max))
                (eq (char-after (match-end 0)) ?\\)) ; \ at EOB
-           (c-put-char-property (1- (point)) 'syntax-table '(15))
+           (c-put-syn-tab (1- (point)) '(15))
            (setq c-new-BEG (min c-new-BEG (point))
                  c-new-END (max c-new-END (match-end 0))) ; Do we need 
c-new-END?
            ))
@@ -1506,16 +1543,16 @@ c-after-change-escape-NL-in-string
                                    nil t)
                 (eq (char-after) ?\")
                 (equal (c-get-char-property (point) 'syntax-table) '(15)))
-       (c-clear-char-property end 'syntax-table)
+       (c-clear-syn-tab end)
        (c-truncate-lit-pos-cache end)
-       (c-clear-char-property (point) 'syntax-table)
+       (c-clear-syn-tab (point))
        (forward-char)                  ; to after the "
        (when
            (and
             ;; Search forward for an end of logical line.
             (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" nil t)
             (memq (char-after) '(?\n ?\r)))
-         (c-clear-char-property (point) 'syntax-table))))))
+         (c-clear-syn-tab (point)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Parsing of quotes.
@@ -1794,6 +1831,11 @@ c-before-change
     ;; property changes.
     (when (fboundp 'syntax-ppss)
       (setq c-syntax-table-hwm most-positive-fixnum))
+;;;; NEW STOUGH, 2019-07-09
+    (unwind-protect
+       (progn
+         (c-restore-string-fences (point-min) (point-max))
+;;;; END OF NEW STOUGH
     (save-restriction
       (save-match-data
        (widen)
@@ -1865,7 +1907,12 @@ c-before-change
          )))
     ;; The following must be done here rather than in `c-after-change' because
     ;; newly inserted parens would foul up the invalidation algorithm.
-    (c-invalidate-state-cache beg)))
+    (c-invalidate-state-cache beg)
+;;;; NEW STOUGH, 2019-07-09
+    )
+      (c-clear-string-fences))
+;;;; END OF NEW STOUGH
+                                 ))
 
 (defvar c-in-after-change-fontification nil)
 (make-variable-buffer-local 'c-in-after-change-fontification)
@@ -1909,6 +1956,11 @@ c-after-change
       ;; When `combine-after-change-calls' is used we might get calls
       ;; with regions outside the current narrowing.  This has been
       ;; observed in Emacs 20.7.
+;;;; NEW STOUGH, 2019-07-09
+      (unwind-protect
+         (progn
+           (c-restore-string-fences (point-min) (point-max))
+;;;; END OF NEW STOUGH
       (save-restriction
        (save-match-data  ; c-recognize-<>-arglists changes match-data
          (widen)
@@ -1945,7 +1997,12 @@ c-after-change
          (save-excursion
            (mapc (lambda (fn)
                    (funcall fn beg end old-len))
-                 c-before-font-lock-functions))))))
+                 c-before-font-lock-functions))))
+;;;; NEW STOUGH, 2019-07-09
+      )
+       (c-clear-string-fences))
+;;;; END OF NEW STOUGH
+                                                 ))
   ;; A workaround for syntax-ppss's failure to notice syntax-table text
   ;; property changes.
   (when (fboundp 'syntax-ppss)
@@ -2173,8 +2230,11 @@ c-font-lock-fontify-region
       ;; Context (etc.) fontification.
       (setq new-region (c-before-context-fl-expand-region beg end)
            new-beg (car new-region)  new-end (cdr new-region)))
-    (funcall (default-value 'font-lock-fontify-region-function)
-            new-beg new-end verbose)))
+    (unwind-protect
+       (progn (c-restore-string-fences new-beg new-end)
+              (funcall (default-value 'font-lock-fontify-region-function)
+                       new-beg new-end verbose))
+      (c-clear-string-fences))))
 
 (defun c-after-font-lock-init ()
   ;; Put on `font-lock-mode-hook'.  This function ensures our after-change
@@ -2291,7 +2351,7 @@ c-electric-pair-inhibit-predicate
 invalid strings with such a syntax table text property on the
 opening \" and the next unescaped end of line."
   (if (eq char ?\")
-      (not (equal (get-text-property (1- (point)) 'syntax-table) '(15)))
+      (not (equal (get-text-property (1- (point)) 'c-fl-syn-tab) '(15)))
     (funcall (default-value 'electric-pair-inhibit-predicate) char)))
 
 


> João

-- 
Alan Mackenzie (Nuremberg, Germany).