X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b2e6b10fe2d40020a75ab0025af98a4abf339cd2..2988341a84f6e5faef7e5f5ce2c55142935d0fee:/lisp/composite.el?ds=sidebyside diff --git a/lisp/composite.el b/lisp/composite.el index 278b7e3bf6..effa8d6d0a 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -1,6 +1,7 @@ ;;; composite.el --- support character composition -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;; 2008, 2009 ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 @@ -8,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,9 +20,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -105,7 +104,7 @@ RULE is a cons of global and new reference point symbols nref (car nref)) (or (and (>= xoff -100) (<= xoff 100) (>= yoff -100) (<= yoff 100)) - (error "Invalid compostion rule: %s" rule)) + (error "Invalid composition rule: %s" rule)) (setq xoff (+ xoff 128) yoff (+ yoff 128))) ;; (GREF . NREF) (setq xoff 0 yoff 0)) @@ -198,7 +197,12 @@ or a vector or list of integers and rules. If it is a character, it is an alternate character to display instead of the text in the region. -If it is a string, the elements are alternate characters. +If it is a string, the elements are alternate characters. In +this case, TAB element has a special meaning. If the first +characer is TAB, the glyphs are displayed with left padding space +so that no pixel overlaps with the previous column. If the last +character is TAB, the glyphs are displayed with rigth padding +space so that no pixel overlaps with the following column. If it is a vector or list, it is a sequence of alternate characters and composition rules, where (2N)th elements are characters and (2N+1)th @@ -290,7 +294,7 @@ If the character at POS has `composition' property, the value is a list of FROM, TO, and VALID-P. FROM and TO specify the range of text that has the same `composition' -property, VALID-P is non-nil if and only if this composition is valid. +property, VALID-P is t if this composition is valid, and nil if not. If there's no composition at POS, and the optional 2nd argument LIMIT is non-nil, search for a composition toward LIMIT. @@ -314,9 +318,16 @@ and composition rules as described in `compose-region'. MOD-FUNC is a modification function of the composition. -WIDTH is a number of columns the composition occupies on the screen." +WIDTH is a number of columns the composition occupies on the screen. + +When Automatic Compostion mode is on, this function also finds a +chunk of text that is automatically composed. If such a chunk is +found closer to POS than the position that has `composition' +property, the value is a list of FROM, TO, and a glyph gstring +the specify how the chunk is composed. See the function +`composition-get-gstring' for the format of the glyph string." (let ((result (find-composition-internal pos limit string detail-p))) - (if (and detail-p result (nth 2 result) (not (nth 3 result))) + (if (and detail-p (> (length result) 3) (nth 2 result) (not (nth 3 result))) ;; This is a valid rule-base composition. (decode-composition-components (nth 2 result) 'nocopy)) result)) @@ -325,42 +336,42 @@ WIDTH is a number of columns the composition occupies on the screen." (defun compose-chars-after (pos &optional limit object) "Compose characters in current buffer after position POS. -It looks up the char-table `composition-function-table' (which see) by -a character after POS. If non-nil value is found, the format of the -value should be an alist of PATTERNs vs FUNCs, where PATTERNs are -regular expressions and FUNCs are functions. If the text after POS -matches one of PATTERNs, call the corresponding FUNC with three -arguments POS, TO, and PATTERN, where TO is the end position of text -matching PATTERN, and return what FUNC returns. Otherwise, return -nil. - -FUNC is responsible for composing the text properly. The return value -is: - nil -- if no characters were composed. - CHARS (integer) -- if CHARS characters were composed. +It looks up the char-table `composition-function-table' (which +see) by a character at POS, and compose characters after POS +according to the contents of `composition-function-table'. -Optional 2nd arg LIMIT, if non-nil, limits the matching of text. +Optional 2nd arg LIMIT, if non-nil, limits characters to compose. Optional 3rd arg OBJECT, if non-nil, is a string that contains the text to compose. In that case, POS and LIMIT index into the string. This function is the default value of `compose-chars-after-function'." (let ((tail (aref composition-function-table (char-after pos))) + (font-obj (and (display-multi-font-p) + (and (not (stringp object)) + (font-at pos (selected-window))))) pattern func result) - (when tail + (or limit + (setq limit (if (stringp object) (length object) (point-max)))) + (when (and font-obj tail) (save-match-data (save-excursion - (while (and tail (not func)) - (setq pattern (car (car tail)) - func (cdr (car tail))) + (while tail + (if (functionp (car tail)) + (setq pattern nil func (car tail)) + (setq pattern (car (car tail)) + func (cdr (car tail)))) (goto-char pos) - (if (if limit - (and (re-search-forward pattern limit t) - (= (match-beginning 0) pos)) - (looking-at pattern)) - (setq result (funcall func pos (match-end 0) pattern nil)) - (setq func nil tail (cdr tail))))))) - result)) + (if pattern + (if (and (if (stringp object) + (eq (string-match pattern object) 0) + (looking-at pattern)) + (<= (match-end 0) limit)) + (setq result + (funcall func pos (match-end 0) font-obj object))) + (setq result (funcall func pos limit font-obj object))) + (if result (setq tail nil)))))) + result)) (defun compose-last-chars (args) "Compose last characters. @@ -387,25 +398,6 @@ after a sequence of character events." ;;; 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. - -Each function is called with two arguments, POS and STRING. - -If STRING is nil, POS is a position in the current buffer, and the -function has to compose a character at POS with surrounding characters -in the current buffer. - -Otherwise, STRING is a string, and POS is an index into the string. In -this case, the function has to compose a character at POS with -surrounding characters in the string. - -See also the command `toggle-auto-composition'.") - ;; Copied from font-lock.el. (eval-when-compile ;; Borrowed from lazy-lock.el. @@ -427,110 +419,311 @@ See also the command `toggle-auto-composition'.") (put 'save-buffer-state 'lisp-indent-function 1) -;; This function is called when a composition created by -;; terminal-composition-function is partially modified. -(defun terminal-composition-modification (from to) - (terminal-composition-function from)) - -(defun terminal-composition-function (pos &optional 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 ((from (1- pos)) - ch) - (if string - (length string) - (setq pos (1+ pos)) - (while (and (< pos (point-max)) - (= (aref char-width-table (char-after pos)) 0)) - (setq pos (1+ pos))) - (if (and (>= from (point-min)) - (= (aref (symbol-name (get-char-code-property - (char-after from) - 'general-category)) 0) ?L)) - (compose-region from pos (buffer-substring from pos)) - (compose-region (1+ from) pos - (concat " " (buffer-substring (1+ from) pos)) - 'terminal-composition-modification)) - pos))) - -(defvar terminal-composition-function-table - (let ((table (make-char-table nil))) - (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.") - -(defvar auto-compose-current-font nil - "The current font-object used for characters being composed automatically.") - -(defun auto-compose-chars (pos string font-object) - "Compose characters after the buffer position POS. -If STRING is non-nil, it is a string, and POS is an index into the string. -In that case, compose characters in the string. -FONT-OBJECT is a font selected for the character at 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-code (glyph code) (aset glyph 3 code)) +(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) + + ;; 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) + (when (and class (>= class 200) (<= class 240)) + (setq xoff 0 yoff 0) + (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) + (setq lb (+ lb xoff) + rb (+ lb xoff) + as (- as yoff) + de (+ de yoff))) + (if (< ascent as) + (setq ascent as)) + (if (< descent de) + (setq descent de)))))) + (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 '(["[[:alpha:]]\\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 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-match-data - (condition-case nil - (let ((start pos) - (limit (if string (length string) (point-max))) - (auto-compose-current-font font-object) - (table (if (display-graphic-p) - composition-function-table - terminal-composition-function-table)) - ch func newpos) - (setq limit - (or (text-property-any pos limit 'auto-composed t string) - limit) - pos - (catch 'tag - (if string - (while (< pos limit) - (setq ch (aref string pos)) - (if (= ch ?\n) - (throw 'tag (1+ pos))) - (setq func (aref table ch)) - (if (and (functionp func) - (setq newpos (funcall func pos string)) - (> newpos pos)) - (setq pos newpos) - (setq pos (1+ pos)))) - (while (< pos limit) - (setq ch (char-after pos)) - (if (= ch ?\n) - (throw 'tag (1+ pos))) - (setq func (aref table ch)) - (if (and (functionp func) - (setq newpos (funcall func pos string)) - (> newpos pos)) - (setq pos newpos) - (setq pos (1+ pos))))) - limit)) - (put-text-property start pos 'auto-composed t string)) - (error nil)))))) + (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) ;;;###autoload (define-minor-mode auto-composition-mode - "Toggle Auto Compostion mode. -With arg, turn Auto Compostion mode off if and only if arg is a non-positive -number; if arg is nil, toggle Auto Compostion mode; anything else turns Auto -Compostion on. + "Toggle Auto Composition mode. +With ARG, turn Auto Composition mode off if and only if ARG is a non-positive +number; if ARG is nil, toggle Auto Composition mode; anything else turns Auto +Composition on. When Auto Composition is enabled, text characters are automatically composed by functions registered in `composition-function-table' (which see). -You can use Global Auto Composition mode to automagically turn on +You can use `global-auto-composition-mode' to turn on Auto Composition mode in all buffers (this is the default)." nil nil nil (if noninteractive @@ -603,7 +796,7 @@ Auto Composition mode in all buffers (this is the default)." (defun toggle-auto-composition (&optional arg) "Change whether automatic character composition is enabled in this buffer. -With arg, enable it iff arg is positive." +With arg, enable it if and only if arg is positive." (interactive "P") (let ((enable (if (null arg) (not auto-composition-function) (> (prefix-numeric-value arg) 0)))) @@ -639,9 +832,11 @@ With arg, enable it iff arg is positive." (setq stop (next-single-property-change (point) 'auto-composed nil to))) (let ((func (aref composition-function-table (following-char))) + (font-obj (and (display-multi-font-p) + (font-at (point) (selected-window)))) (pos (point))) - (if (functionp func) - (goto-char (funcall func (point) nil))) + (if (and (functionp func) font-obj) + (goto-char (funcall func (point) to font-obj nil))) (if (<= (point) pos) (forward-char 1))))) (put-text-property from to 'auto-composed t)