[Emacs-diffs] Changes to emacs/lisp/composite.el,v

[Kenichi Handa]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Kenichi Handa <handa>   08/08/29 07:59:03

Index: composite.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/composite.el,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -b -r1.34 -r1.35
--- composite.el        29 Jun 2008 14:44:12 -0000      1.34
+++ composite.el        29 Aug 2008 07:59:03 -0000      1.35
@@ -391,35 +391,6 @@
 
 ;;; Automatic character composition.
 
-(defvar composition-function-table
-  (make-char-table nil)
-  "Char table of functions for automatic character composition.
-For each character that has to be composed automatically with
-preceding and/or following characters, this char table contains
-a function to call to compose that character.
-
-An element, if non-nil, is FUNC or an alist of PATTERNs vs FUNCs,
-where PATTERNs are regular expressions and FUNCs are functions.
-If the element is FUNC, FUNC itself determines the region to
-compose.
-
-Each function is called with 4 arguments, FROM, TO, FONT-OBJECT,
-and STRING.
-
-If STRING is nil, FROM and TO are positions specifying the region
-matching with PATTERN in the current buffer, and the function has
-to compose character in that region (possibly with characters
-preceding FROM).  FONT-OBJECT may be nil if not
-available (e.g. for the case of terminal).  The return value of
-the function is the end position where characters are composed,
-or nil if no composition is made.
-
-Otherwise, STRING is a string, and FROM and TO are indices into
-the string.  In this case, the function has to compose a
-character in the string.  The others are the same as above.
-
-See also the documentation of `auto-composition-mode'.")
-
 ;; Copied from font-lock.el.
 (eval-when-compile
   ;; Borrowed from lazy-lock.el.
@@ -441,111 +412,288 @@
 
 (put 'save-buffer-state 'lisp-indent-function 1)
 
-(defsubst terminal-composition-base-character-p (ch)
-  (not (memq (get-char-code-property ch 'general-category)
-            '(Mn Mc Me Zs Zl Zp Cc Cf Cs))))
-
-(defun terminal-composition-function (from to font-object string)
-  "General composition function used on terminal.
-Non-spacing characters are composed with the preceding spacing
-character.  All non-spacing characters has this function in
-`terminal-composition-function-table'."
-  (let ((pos from))
-    (if string
-       (progn
-         (while (and (< pos to)
-                     (= (aref char-width-table (aref string pos)) 0))
-           (setq pos (1+ pos)))
-         (if (and (> from 0)
-                  (terminal-composition-base-character-p
-                   (aref string (1- from))))
-             (compose-string string (1- from) pos)
-           (compose-string string from pos
-                           (concat " " (buffer-substring from pos)))))
-      (while (and (< pos to)
-                 (= (aref char-width-table (char-after pos)) 0))
-       (setq pos (1+ pos)))
-      (if (and (> from (point-min))
-              (terminal-composition-base-character-p (char-after (1- from))))
-         (compose-region (1- from) pos)
-       (compose-region from pos
-                       (concat " " (buffer-substring from pos)))))
-    pos))
+;; These macros must match with C macros LGSTRING_XXX and LGLYPH_XXX in font.h
+(defsubst lgstring-header (gstring) (aref gstring 0))
+(defsubst lgstring-set-header (gstring header) (aset gstring 0 header))
+(defsubst lgstring-font (gstring) (aref (lgstring-header gstring) 0))
+(defsubst lgstring-char (gstring i) (aref (lgstring-header gstring) (1+ i)))
+(defsubst lgstring-char-len (gstring) (1- (length (lgstring-header gstring))))
+(defsubst lgstring-shaped-p (gstring) (aref gstring 1))
+(defsubst lgstring-set-id (gstring id) (aset gstring 1 id))
+(defsubst lgstring-glyph (gstring i) (aref gstring (+ i 2)))
+(defsubst lgstring-glyph-len (gstring) (- (length gstring) 2))
+(defsubst lgstring-set-glyph (gstring i glyph) (aset gstring (+ i 2) glyph))
+
+(defsubst lglyph-from (glyph) (aref glyph 0))
+(defsubst lglyph-to (glyph) (aref glyph 1))
+(defsubst lglyph-char (glyph) (aref glyph 2))
+(defsubst lglyph-code (glyph) (aref glyph 3))
+(defsubst lglyph-width (glyph) (aref glyph 4))
+(defsubst lglyph-lbearing (glyph) (aref glyph 5))
+(defsubst lglyph-rbearing (glyph) (aref glyph 6))
+(defsubst lglyph-ascent (glyph) (aref glyph 7))
+(defsubst lglyph-descent (glyph) (aref glyph 8))
+(defsubst lglyph-adjustment (glyph) (aref glyph 9))
+
+(defsubst lglyph-set-from-to (glyph from to)
+  (progn (aset glyph 0 from) (aset glyph 1 to)))
+(defsubst lglyph-set-char (glyph char) (aset glyph 2 char))
+(defsubst lglyph-set-width (glyph width) (aset glyph 4 width))
+(defsubst lglyph-set-adjustment (glyph &optional xoff yoff wadjust)
+  (aset glyph 9 (vector (or xoff 0) (or yoff 0) (or wadjust 0))))
+
+(defsubst lglyph-copy (glyph) (copy-sequence glyph))
+
+(defun lgstring-insert-glyph (gstring idx glyph)
+  (let ((nglyphs (lgstring-glyph-len gstring))
+       (i idx) g)
+    (while (and (< i nglyphs) (setq g (lgstring-glyph gstring i)))
+      (setq i (1+ i)))
+    (if (= i nglyphs)
+       (setq gstring (vconcat gstring (vector glyph)))
+      (if (< (1+ i) nglyphs)
+         (lgstring-set-glyph gstring (1+ i) nil)))
+    (while (> i idx)
+      (lgstring-set-glyph gstring i (lgstring-glyph gstring (1- i)))
+      (setq i (1- i)))
+    (lgstring-set-glyph gstring i glyph)
+    gstring))
+
+(defun compose-glyph-string (gstring from to)
+  (let ((glyph (lgstring-glyph gstring from))
+       from-pos to-pos
+       ascent descent lbearing rbearing)
+    (setq from-pos (lglyph-from glyph)
+         to-pos (lglyph-to (lgstring-glyph gstring (1- to))))
+    (lglyph-set-from-to glyph from-pos to-pos)
+    (setq from (1+ from))
+    (while (and (< from to)
+               (setq glyph (lgstring-glyph gstring from)))
+      (lglyph-set-from-to glyph from-pos to-pos)
+      (let ((xoff (if (<= (lglyph-rbearing glyph) 0) 0
+                   (- (lglyph-width glyph)))))
+       (lglyph-set-adjustment glyph xoff 0 0))
+      (setq from (1+ from)))
+    gstring))
+
+(defun compose-glyph-string-relative (gstring from to &optional gap)
+  (let ((font-object (lgstring-font gstring))
+       (glyph (lgstring-glyph gstring from))
+       from-pos to-pos
+       ascent descent lbearing rbearing)
+    (if gap
+       (setq gap (floor (* (font-get font-object :size) gap)))
+      (setq gap 0))
+    (setq from-pos (lglyph-from glyph)
+         to-pos (lglyph-to (lgstring-glyph gstring (1- to)))
+         ascent (lglyph-ascent glyph)
+         descent (lglyph-descent glyph))
+    (lglyph-set-from-to glyph from-pos to-pos)
+    (setq from (1+ from))
+    (while (< from to)
+      (setq glyph (lgstring-glyph gstring from))
+      (lglyph-set-from-to glyph from-pos to-pos)
+      (let ((this-ascent (lglyph-ascent glyph))
+           (this-descent (lglyph-descent glyph))
+           xoff yoff wadjust)
+       (setq xoff (if (<= (lglyph-rbearing glyph) 0) 0
+                    (- (lglyph-width glyph))))
+       (if (> this-ascent 0)
+           (if (< this-descent 0)
+               (setq yoff (- 0 ascent gap this-descent)
+                     ascent (+ ascent gap this-ascent this-descent))
+             (setq yoff 0))
+         (setq yoff (+ descent gap this-ascent)
+               descent (+ descent gap this-ascent this-descent)))
+       (if (or (/= xoff 0) (/= yoff 0))
+           (lglyph-set-adjustment glyph xoff yoff 0)))
+      (setq from (1+ from)))
+    gstring))
+
+(defun compose-gstring-for-graphic (gstring)
+  "Compose glyph-string GSTRING for graphic display.
+Non-spacing characters are composed with the preceding base
+character.  If the preceding character is not a base character,
+each non-spacing character is composed as a spacing character by
+a padding space before and/or after the character.
+
+All non-spacing characters has this function in
+`composition-function-table' unless overwritten."
+  (let* ((header (lgstring-header gstring))
+        (nchars (lgstring-char-len gstring))
+        (nglyphs (lgstring-glyph-len gstring))
+        (glyph (lgstring-glyph gstring 0)))
+    (cond
+     ;; A non-spacing character not following a proper base character.
+     ((= nchars 1)
+      (let ((lbearing (lglyph-lbearing glyph))
+           (rbearing (lglyph-rbearing glyph))
+           (width (lglyph-width glyph))
+           xoff wadjust)
+       (if (< lbearing 0)
+           (setq xoff (- lbearing))
+         (setq xoff 0 lbearing 0))
+       (if (< rbearing width)
+           (setq rbearing width))
+       (lglyph-set-adjustment glyph xoff 0 (- rbearing lbearing))
+       gstring))
+
+     ;; This sequence doesn't start with a proper base character.
+     ((memq (get-char-code-property (lgstring-char gstring 0)
+                                   'general-category)
+           '(Mn Mc Me Zs Zl Zp Cc Cf Cs))
+      nil)
 
-(defvar terminal-composition-function-table
-  (let ((table (make-char-table nil)))
+     ;; A base character and the following non-spacing characters.
+     (t
+      (let ((gstr (font-shape-gstring gstring)))
+       (if (and gstr
+                (> (lglyph-to (lgstring-glyph gstr 0)) 0))
+           gstr
+         ;; The shaper of the font couldn't shape the gstring.
+         ;; Shape them according to canonical-combining-class.
+         (lgstring-set-id gstring nil)
+         (let* ((width (lglyph-width glyph))
+                (ascent (lglyph-ascent glyph))
+                (descent (lglyph-descent glyph))
+                (rbearing (lglyph-rbearing glyph))
+                (lbearing (lglyph-lbearing glyph))
+                (center (/ (+ lbearing rbearing) 2))
+                (gap (round (* (font-get (lgstring-font gstring) :size) 0.1)))
+                xoff yoff)
+           (dotimes (i nchars)
+             (setq glyph (lgstring-glyph gstring i))
+             (when (> i 0)
+               (let* ((class (get-char-code-property
+                              (lglyph-char glyph) 'canonical-combining-class))
+                      (lb (lglyph-lbearing glyph))
+                      (rb (lglyph-rbearing glyph))
+                      (as (lglyph-ascent glyph))
+                      (de (lglyph-descent glyph))
+                      (ce (/ (+ lb rb) 2))
+                      xoff yoff)
+                 (if (and
+                      class (>= class 200) (<= class 240)
+                      (cond
+                       ((= class 200)
+                        (setq xoff (- lbearing ce)
+                              yoff (if (> as 0) 0 (+ descent as))))
+                       ((= class 202)
+                        (if (> as 0) (setq as 0))
+                        (setq xoff (- center ce)
+                              yoff (if (> as 0) 0 (+ descent as))))
+                       ((= class 204)
+                        (if (> as 0) (setq as 0))
+                        (setq xoff (- rbearing ce)
+                              yoff (if (> as 0) 0 (+ descent as))))
+                       ((= class 208)
+                        (setq xoff (- lbearing rb)))
+                       ((= class 210)
+                        (setq xoff (- rbearing lb)))
+                       ((= class 212)
+                        (setq xoff (- lbearing ce)
+                              yoff (if (>= de 0) 0 (- ascent de))))
+                       ((= class 214)
+                        (setq xoff (- center ce)
+                              yoff (if (>= de 0) 0 (- ascent de))))
+                       ((= class 216)
+                        (setq xoff (- rbearing ce)
+                              yoff (if (>= de 0) 0 (- ascent de))))
+                       ((= class 218)
+                        (setq xoff (- lbearing ce)
+                              yoff (if (> as 0) 0 (+ descent as gap))))
+                       ((= class 220)
+                        (setq xoff (- center ce)
+                              yoff (if (> as 0) 0 (+ descent as gap))))
+                       ((= class 222)
+                        (setq xoff (- rbearing ce)
+                              yoff (if (> as 0) 0 (+ descent as gap))))
+                       ((= class 224)
+                        (setq xoff (- lbearing rb)))
+                       ((= class 226)
+                        (setq xoff (- rbearing lb)))
+                       ((= class 228)
+                        (setq xoff (- lbearing ce)
+                              yoff (if (>= de 0) 0 (- ascent de gap))))
+                       ((= class 230)
+                        (setq xoff (- center ce)
+                              yoff (if (>= de 0) 0 (- ascent de gap))))
+                       ((= class 232)
+                        (setq xoff (- rbearing ce)
+                              yoff (if (>= de 0) 0 (- ascent de gap))))))
+                     (lglyph-set-adjustment glyph (- xoff width) yoff))))))
+         (let ((i 0))
+           (while (and (< i nglyphs) (setq glyph (lgstring-glyph gstring i)))
+             (lglyph-set-from-to glyph 0 (1- nchars))
+             (setq i (1+ i))))
+         gstring))))))
+
+(let ((elt '(["\\C^\\c^+" 1 compose-gstring-for-graphic]
+            [nil 0 compose-gstring-for-graphic])))
     (map-char-table
      #'(lambda (key val)
-        (if (= val 0) (set-char-table-range table key
-                                            'terminal-composition-function)))
-     char-width-table)
-    table)
-  "Char table of functions for automatic character composition on terminal.
-This is like `composition-function-table' but used when Emacs is running
-on a terminal.")
-
-(defun auto-compose-chars (from to window string)
-  "Compose characters in the region between FROM and TO.
-WINDOW is a window displaying the current buffer.
+       (if (= val 0)
+          (set-char-table-range composition-function-table key elt)))
+   char-width-table))
+
+(defun compose-gstring-for-terminal (gstring)
+  "Compose glyph string GSTRING for terminal display.
+Non-spacing characters are composed with the preceding base
+character.  If the preceding character is not a base character,
+each non-spacing character is composed as a spacing character by
+a prepending a space before it."
+  (let* ((header (lgstring-header gstring))
+        (nchars (lgstring-char-len gstring))
+        (nglyphs (lgstring-glyph-len gstring))
+        (i 0)
+        glyph)
+    (while (and (< i nglyphs)
+               (setq glyph (lgstring-glyph gstring i)))
+      (if (= (lglyph-width glyph) 0)
+         (progn
+           ;; Compose by prepending a space.
+           (setq gstring (lgstring-insert-glyph gstring i (lglyph-copy glyph))
+                 nglyphs (lgstring-glyph-len gstring))
+           (lglyph-set-char (lgstring-glyph gstring i) 32)
+           (setq i (+ 2)))
+       (let ((from (lglyph-from glyph))
+             (to (lglyph-to glyph))
+             (j (1+ i)))
+         (while (and (< j nglyphs)
+                     (setq glyph (lgstring-glyph gstring j))
+                     (= (lglyph-width glyph) 0))
+           (setq to (lglyph-to glyph)
+                 j (1+ j)))
+         (while (< i j)
+           (setq glyph (lgstring-glyph gstring i))
+           (lglyph-set-from-to glyph from to)
+           (setq i (1+ i))))))
+    gstring))
+
+
+(defun auto-compose-chars (func from to font-object string)
+  "Compose the characters at FROM by FUNC.
+FUNC is called with one argument GSTRING which is built for characters
+in the region FROM (inclusive) and TO (exclusive).
+
+If the character are composed on a graphic display, FONT-OBJECT
+is a font to use.
+
+Otherwise, FONT-OBJECT is nil, and the fucntion
+`compose-gstring-for-terminal' is used instead of FUNC.
+
 If STRING is non-nil, it is a string, and FROM and TO are indices
 into the string.  In that case, compose characters in the string.
 
+The value is a gstring containing information for shaping the characters.
+
 This function is the default value of `auto-composition-function' (which see)."
-  (save-buffer-state nil
-    (save-excursion
-      (save-restriction
-       (save-match-data
-         (let ((table (if (display-graphic-p)
-                          composition-function-table
-                        terminal-composition-function-table))
-               (start from))
-           (setq to (or (text-property-any (1+ from) to 'auto-composed t
-                                           string)
-                        to))
-           (if string
-               (while (< from to)
-                 (let* ((ch (aref string from))
-                        (elt (aref table ch))
-                        font-obj newpos)
-                   (when (and elt
-                              (or (not (display-graphic-p))
-                                  (setq font-obj (font-at from window 
string))))
-                     (if (functionp elt)
-                         (setq newpos (funcall elt from to font-obj string))
-                       (while (and elt
-                                   (or (not (eq (string-match (caar elt) string
-                                                              from)
-                                                from))
-                                       (not (setq newpos
-                                                  (funcall (cdar elt) from
-                                                           (match-end 0)
-                                                           font-obj string)))))
-                         (setq elt (cdr elt)))))
-                   (if (and newpos (> newpos from))
-                       (setq from newpos)
-                     (setq from (1+ from)))))
-             (narrow-to-region from to)
-             (while (< from to)
-                 (let* ((ch (char-after from))
-                        (elt (aref table ch))
-                        func pattern font-obj newpos)
-                   (when (and elt
-                              (or (not (display-graphic-p))
-                                  (setq font-obj (font-at from window))))
-                     (if (functionp elt)
-                         (setq newpos (funcall elt from to font-obj nil))
-                       (goto-char from)
-                       (while (and elt
-                                   (or (not (looking-at (caar elt)))
-                                       (not (setq newpos
-                                                  (funcall (cdar elt) from
-                                                           (match-end 0)
-                                                           font-obj nil)))))
-                         (setq elt (cdr elt)))))
-                   (if (and newpos (> newpos from))
-                       (setq from newpos)
-                     (setq from (1+ from))))))
-           (put-text-property start to 'auto-composed t string)))))))
+  (let ((gstring (composition-get-gstring from to font-object string)))
+    (if (lgstring-shaped-p gstring)
+       gstring
+      (or font-object
+         (setq func 'compose-gstring-for-terminal))
+      (funcall func gstring))))
 
 (make-variable-buffer-local 'auto-composition-function)