X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/26e06f4464c58704889bdc536edc25b73e8c0179..06b605171f1c9d8b42bd3326a243b8b03d2e4e58:/lisp/composite.el diff --git a/lisp/composite.el b/lisp/composite.el index 6d1a2f0bba..11a3d5ba38 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -1,11 +1,14 @@ ;;; composite.el --- support character composition ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008 +;; 2008, 2009, 2010, 2011 ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 +;; Author: Kenichi HANDA +;; (according to ack.texi) ;; Keywords: mule, multilingual, character composition +;; Package: emacs ;; This file is part of GNU Emacs. @@ -26,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (defconst reference-point-alist '((tl . 0) (tc . 1) (tr . 2) (Bl . 3) (Bc . 4) (Br . 5) @@ -42,7 +47,7 @@ A glyph reference point symbol is to be used to specify a composition rule in COMPONENTS argument to such functions as `compose-region'. -Meanings of glyph reference point codes are as follows: +The meaning of glyph reference point codes is as follows: 0----1----2 <---- ascent 0:tl or top-left | | 1:tc or top-center @@ -75,7 +80,7 @@ follows (the point `*' corresponds to both reference points): +----+-----+ <--- new descent A composition rule may have the form \(GLOBAL-REF-POINT -NEW-REF-POINT XOFF YOFF), where XOFF and YOFF specifies how much +NEW-REF-POINT XOFF YOFF), where XOFF and YOFF specify how much to shift NEW-REF-POINT from GLOBAL-REF-POINT. In this case, XOFF and YOFF are integers in the range -100..100 representing the shifting percentage against the font size.") @@ -183,8 +188,17 @@ RULE is a cons of global and new reference point symbols (defun compose-region (start end &optional components modification-func) "Compose characters in the current region. -Characters are composed relatively, i.e. composed by overstricking or -stacking depending on ascent, descent and other properties. +Characters are composed relatively, i.e. composed by overstriking +or stacking depending on ascent, descent and other metrics of +glyphs. + +For instance, if the region has three characters \"XYZ\", X is +regarded as BASE glyph, and Y is displayed: + (1) above BASE if Y's descent value is not positive + (2) below BASE if Y's ascent value is not positive + (3) on BASE (i.e. at the BASE position) otherwise +and Z is displayed with the same rule while regarding the whole +XY glyphs as BASE. When called from a program, expects these four arguments. @@ -199,9 +213,9 @@ of the text in the region. 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 +character 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 +character is TAB, the glyphs are displayed with right 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 @@ -211,7 +225,7 @@ elements with previously composed N glyphs. A composition rule is a cons of global and new glyph reference point symbols. See the documentation of `reference-point-alist' for more -detail. +details. Optional 4th argument MODIFICATION-FUNC is a function to call to adjust the composition when it gets invalid because of a change of @@ -275,9 +289,7 @@ A composition rule is a cons of glyph reference points of the form (let (str components) (if (consp (car (cdr args))) ;; Rule-base composition. - (let ((len (length args)) - (tail (encode-composition-components args 'nocopy))) - + (let ((tail (encode-composition-components args 'nocopy))) (while tail (setq str (cons (car tail) str)) (setq tail (nthcdr 2 tail))) @@ -288,16 +300,16 @@ A composition rule is a cons of glyph reference points of the form (compose-string-internal str 0 (length str) components))) (defun find-composition (pos &optional limit string detail-p) - "Return information about a composition at or nearest to buffer position POS. + "Return information about a composition at or near buffer position POS. If the character at POS has `composition' property, the value is a list -of FROM, TO, and VALID-P. +\(FROM TO VALID-P). FROM and TO specify the range of text that has the same `composition' 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. +is non-nil, search for a composition toward the position given by LIMIT. If no composition is found, return nil. @@ -305,8 +317,9 @@ Optional 3rd argument STRING, if non-nil, is a string to look for a composition in; nil means the current buffer. If a valid composition is found and the optional 4th argument DETAIL-P -is non-nil, the return value is a list of FROM, TO, COMPONENTS, -RELATIVE-P, MOD-FUNC, and WIDTH. +is non-nil, the return value is a list of the form + + (FROM TO COMPONENTS RELATIVE-P MOD-FUNC WIDTH) COMPONENTS is a vector of integers, the meaning depends on RELATIVE-P. @@ -320,12 +333,12 @@ MOD-FUNC is a modification function of the composition. WIDTH is a number of columns the composition occupies on the screen. -When Automatic Compostion mode is on, this function also finds a +When Automatic Composition 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." +property, the value is a list of FROM, TO, and a glyph-string +that specifies how the chunk is to be 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 (> (length result) 3) (nth 2 result) (not (nth 3 result))) ;; This is a valid rule-base composition. @@ -398,27 +411,6 @@ after a sequence of character events." ;;; Automatic character composition. -;; Copied from font-lock.el. -(eval-when-compile - ;; Borrowed from lazy-lock.el. - ;; We use this to preserve or protect things when modifying text properties. - (defmacro save-buffer-state (varlist &rest body) - "Bind variables according to VARLIST and eval BODY restoring buffer state." - `(let* ,(append varlist - '((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark buffer-file-name buffer-file-truename)) - ,@body - (unless modified - (restore-buffer-modified-p nil)))) - ;; Fixme: This makes bootstrapping fail with this error. - ;; Symbol's function definition is void: eval-defun - ;;(def-edebug-spec save-buffer-state let) - ) - -(put 'save-buffer-state 'lisp-indent-function 1) - ;; 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)) @@ -445,6 +437,7 @@ after a sequence of character events." (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)))) @@ -453,8 +446,8 @@ after a sequence of character events." (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))) + (i idx)) + (while (and (< i nglyphs) (lgstring-glyph gstring i)) (setq i (1+ i))) (if (= i nglyphs) (setq gstring (vconcat gstring (vector glyph))) @@ -468,8 +461,7 @@ after a sequence of character events." (defun compose-glyph-string (gstring from to) (let ((glyph (lgstring-glyph gstring from)) - from-pos to-pos - ascent descent lbearing rbearing) + from-pos to-pos) (setq from-pos (lglyph-from glyph) to-pos (lglyph-to (lgstring-glyph gstring (1- to)))) (lglyph-set-from-to glyph from-pos to-pos) @@ -487,7 +479,7 @@ after a sequence of character events." (let ((font-object (lgstring-font gstring)) (glyph (lgstring-glyph gstring from)) from-pos to-pos - ascent descent lbearing rbearing) + ascent descent) (if gap (setq gap (floor (* (font-get font-object :size) gap))) (setq gap 0)) @@ -502,7 +494,7 @@ after a sequence of character events." (lglyph-set-from-to glyph from-pos to-pos) (let ((this-ascent (lglyph-ascent glyph)) (this-descent (lglyph-descent glyph)) - xoff yoff wadjust) + xoff yoff) (setq xoff (if (<= (lglyph-rbearing glyph) 0) 0 (- (lglyph-width glyph)))) (if (> this-ascent 0) @@ -519,24 +511,23 @@ after a sequence of character events." (defun compose-gstring-for-graphic (gstring) "Compose glyph-string GSTRING for graphic display. -Non-spacing characters are composed with the preceding base +Combining 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 +each combining 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 +All non-spacing characters have 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))) + (let ((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) + xoff) (if (< lbearing 0) (setq xoff (- lbearing)) (setq xoff 0 lbearing 0)) @@ -566,8 +557,7 @@ All non-spacing characters has this function in (rbearing (lglyph-rbearing glyph)) (lbearing (lglyph-lbearing glyph)) (center (/ (+ lbearing rbearing) 2)) - (gap (round (* (font-get (lgstring-font gstring) :size) 0.1))) - xoff yoff) + (gap (round (* (font-get (lgstring-font gstring) :size) 0.1)))) (dotimes (i nchars) (setq glyph (lgstring-glyph gstring i)) (when (> i 0) @@ -643,46 +633,68 @@ All non-spacing characters has this function in (setq i (1+ i)))) gstring)))))) -(let ((elt '(["[[:alpha:]]\\c^+" 1 compose-gstring-for-graphic] +(let ((elt `([,(purecopy "\\c.\\c^+") 1 compose-gstring-for-graphic] [nil 0 compose-gstring-for-graphic]))) (map-char-table #'(lambda (key val) - (if (= val 0) + (if (memq val '(Mn Mc Me)) (set-char-table-range composition-function-table key elt))) - char-width-table)) + unicode-category-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) +prepending a space before it." + (let ((nglyphs (lgstring-glyph-len gstring)) + (i 0) + (coding (lgstring-font gstring)) + glyph) (while (and (< i nglyphs) (setq glyph (lgstring-glyph gstring i))) - (if (= (lglyph-width glyph) 0) + (if (not (char-charset (lglyph-char glyph) coding)) (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)))))) + ;; As the terminal doesn't support this glyph, return a + ;; gstring in which each glyph is its own graphme-cluster + ;; of width 1.. + (setq i 0) + (while (and (< i nglyphs) + (setq glyph (lgstring-glyph gstring i))) + (if (< (lglyph-width glyph) 1) + (lglyph-set-width glyph 1)) + (lglyph-set-from-to glyph i i) + (setq i (1+ i)))) + (if (= (lglyph-width glyph) 0) + (if (eq (get-char-code-property (lglyph-char glyph) + 'general-category) + 'Cf) + (progn + ;; Compose by replacing with a space. + (lglyph-set-char glyph 32) + (lglyph-set-width glyph 1) + (setq i (1+ i))) + ;; Compose by prepending a space. + (setq gstring (lgstring-insert-glyph gstring i + (lglyph-copy glyph)) + nglyphs (lgstring-glyph-len gstring)) + (setq glyph (lgstring-glyph gstring i)) + (lglyph-set-char glyph 32) + (lglyph-set-width glyph 1) + (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)) + (char-charset (lglyph-char glyph) coding) + (= (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)) @@ -692,9 +704,7 @@ 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 +is a font to use. Otherwise, FONT-OBJECT is nil, and the function `compose-gstring-for-terminal' is used instead of FUNC. If STRING is non-nil, it is a string, and FROM and TO are indices @@ -706,11 +716,14 @@ This function is the default value of `auto-composition-function' (which see)." (let ((gstring (composition-get-gstring from to font-object string))) (if (lgstring-shaped-p gstring) gstring - (or font-object + (or (fontp font-object 'font-object) (setq func 'compose-gstring-for-terminal)) (funcall func gstring)))) +(put 'auto-composition-mode 'permanent-local t) + (make-variable-buffer-local 'auto-composition-function) +(setq-default auto-composition-function 'auto-compose-chars) ;;;###autoload (define-minor-mode auto-composition-mode @@ -724,141 +737,21 @@ by functions registered in `composition-function-table' (which see). 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 - (setq auto-composition-mode nil)) - (cond (auto-composition-mode - (add-hook 'after-change-functions 'auto-composition-after-change nil t) - (setq auto-composition-function 'auto-compose-chars)) - (t - (remove-hook 'after-change-functions 'auto-composition-after-change t) - (setq auto-composition-function nil))) - (save-buffer-state nil - (save-restriction - (widen) - (remove-text-properties (point-min) (point-max) '(auto-composed nil)) - (decompose-region (point-min) (point-max))))) - -(defun auto-composition-after-change (start end old-len) - (save-buffer-state nil - (if (< start (point-min)) - (setq start (point-min))) - (if (> end (point-max)) - (setq end (point-max))) - (when (and auto-composition-mode (not memory-full)) - (let (func1 func2) - (when (and (> start (point-min)) - (setq func2 (aref composition-function-table - (char-after (1- start)))) - (or (= start (point-max)) - (not (setq func1 (aref composition-function-table - (char-after start)))) - (eq func1 func2))) - (setq start (1- start) - func1 func2) - (while (eq func1 func2) - (if (> start (point-min)) - (setq start (1- start) - func2 (aref composition-function-table - (char-after start))) - (setq func2 nil)))) - (when (and (< end (point-max)) - (setq func2 (aref composition-function-table - (char-after end))) - (or (= end (point-min)) - (not (setq func1 (aref composition-function-table - (char-after (1- end))))) - (eq func1 func2))) - (setq end (1+ end) - func1 func2) - (while (eq func1 func2) - (if (< end (point-max)) - (setq func2 (aref composition-function-table - (char-after end)) - end (1+ end)) - (setq func2 nil)))) - (if (< start end) - (remove-text-properties start end '(auto-composed nil))))))) - -(defun turn-on-auto-composition-if-enabled () - (if enable-multibyte-characters - (auto-composition-mode 1))) + ;; It's defined in C, this stops the d-m-m macro defining it again. + :variable auto-composition-mode) +;; It's not defined with DEFVAR_PER_BUFFER though. +(make-variable-buffer-local 'auto-composition-mode) ;;;###autoload -(define-global-minor-mode global-auto-composition-mode - auto-composition-mode turn-on-auto-composition-if-enabled - :extra-args (dummy) - :initialize 'custom-initialize-safe-default - :init-value (not noninteractive) - :group 'auto-composition - :version "23.1") - -(defun toggle-auto-composition (&optional arg) - "Change whether automatic character composition is enabled in this buffer. -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)))) - (if enable - (kill-local-variable 'auto-composition-function) - (make-local-variable 'auto-composition-function) - (setq auto-composition-function nil) - (save-buffer-state nil - (save-restriction - (widen) - (decompose-region (point-min) (point-max))))) - - (save-buffer-state nil - (save-restriction - (widen) - (remove-text-properties (point-min) (point-max) - '(auto-composed nil)))))) - -(defun auto-compose-region (from to) - "Force automatic character composition on the region FROM and TO." - (save-excursion - (if (get-text-property from 'auto-composed) - (setq from (next-single-property-change from 'auto-composed nil to))) - (goto-char from) - (let ((modified-p (buffer-modified-p)) - (inhibit-read-only '(composition auto-composed)) - (stop (next-single-property-change (point) 'auto-composed nil to))) - (while (< (point) to) - (if (= (point) stop) - (progn - (goto-char (next-single-property-change (point) - 'auto-composed nil to)) - (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 (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) - (set-buffer-modified-p modified-p)))) - - -;; The following codes are only for backward compatibility with Emacs -;; 20.4 and earlier. - -(defun decompose-composite-char (char &optional type with-composition-rule) - "Convert CHAR to string. - -If optional 2nd arg TYPE is non-nil, it is `string', `list', or -`vector'. In this case, CHAR is converted to string, list of CHAR, or -vector of CHAR respectively. -Optional 3rd arg WITH-COMPOSITION-RULE is ignored." - (cond ((or (null type) (eq type 'string)) (char-to-string char)) - ((eq type 'list) (list char)) - (t (vector char)))) +(define-minor-mode global-auto-composition-mode + "Toggle Auto-Composition mode in every possible buffer. +With prefix arg, turn Global-Auto-Composition mode on if and only if arg +is positive. +See `auto-composition-mode' for more information on Auto-Composition mode." + :variable (default-value 'auto-composition-mode)) -(make-obsolete 'decompose-composite-char 'char-to-string "21.1") +(defalias 'toggle-auto-composition 'auto-composition-mode) -;; arch-tag: ee703d77-1723-45d4-a31f-e9f0f867aa33 ;;; composite.el ends here