diff options
| author | Kenichi Handa | 2006-07-04 03:36:57 +0000 |
|---|---|---|
| committer | Kenichi Handa | 2006-07-04 03:36:57 +0000 |
| commit | d042f8b42609ab5d2fcf9cfc3917d8ebe962db91 (patch) | |
| tree | 0387f25fa8a73e78fad01f7696e3d88eef897ef0 | |
| parent | 997c19d3c9f948247ed3a247024623122b592f22 (diff) | |
| download | emacs-d042f8b42609ab5d2fcf9cfc3917d8ebe962db91.tar.gz emacs-d042f8b42609ab5d2fcf9cfc3917d8ebe962db91.zip | |
(set-language-info): If LANG-ENV is
the current one, don't call set-language-environment, but call one
of set-language-environment-XXX to make INFO effective now.
(set-language-environment): Call set-language-environment-XXX
functions instead of doing the various setups directly.
(set-language-environment-coding-systems): Argument eol-type
deleted.
(set-language-environment-input-method)
(set-language-environment-nonascii-translation)
(set-language-environment-charset)
(set-language-environment-fontset)
(set-language-environment-unibyte): New functions.
| -rw-r--r-- | lisp/international/mule-cmds.el | 188 |
1 files changed, 104 insertions, 84 deletions
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 93c075442f6..ae664121a5d 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el | |||
| @@ -1128,7 +1128,19 @@ see `language-info-alist'." | |||
| 1128 | (setq lang-env (symbol-name lang-env))) | 1128 | (setq lang-env (symbol-name lang-env))) |
| 1129 | (set-language-info-internal lang-env key info) | 1129 | (set-language-info-internal lang-env key info) |
| 1130 | (if (equal lang-env current-language-environment) | 1130 | (if (equal lang-env current-language-environment) |
| 1131 | (set-language-environment lang-env))) | 1131 | (cond ((eq key 'coding-priority) |
| 1132 | (set-language-environment-coding-systems lang-env)) | ||
| 1133 | ((eq key 'input-method) | ||
| 1134 | (set-language-environment-input-method lang-env)) | ||
| 1135 | ((eq key 'nonascii-translation) | ||
| 1136 | (set-language-environment-nonascii-translation lang-env)) | ||
| 1137 | ((eq key 'charset) | ||
| 1138 | (set-language-environment-charset lang-env)) | ||
| 1139 | ((eq key 'overriding-fontspec) | ||
| 1140 | (set-language-environment-fontset lang-env)) | ||
| 1141 | ((and (not default-enable-multibyte-characters) | ||
| 1142 | (or (eq key 'unibyte-syntax) (eq key 'unibyte-display))) | ||
| 1143 | (set-language-environment-unibyte lang-env))))) | ||
| 1132 | 1144 | ||
| 1133 | (defun set-language-info-internal (lang-env key info) | 1145 | (defun set-language-info-internal (lang-env key info) |
| 1134 | "Internal use only. | 1146 | "Internal use only. |
| @@ -1835,92 +1847,29 @@ specifies the character set for the major languages of Western Europe." | |||
| 1835 | 'exit-function))) | 1847 | 'exit-function))) |
| 1836 | (run-hooks 'exit-language-environment-hook) | 1848 | (run-hooks 'exit-language-environment-hook) |
| 1837 | (if (functionp func) (funcall func)))) | 1849 | (if (functionp func) (funcall func)))) |
| 1838 | (let ((default-eol-type (coding-system-eol-type | ||
| 1839 | default-buffer-file-coding-system))) | ||
| 1840 | (reset-language-environment) | ||
| 1841 | |||
| 1842 | ;; The features might set up coding systems. | ||
| 1843 | (let ((required-features (get-language-info language-name 'features))) | ||
| 1844 | (while required-features | ||
| 1845 | (require (car required-features)) | ||
| 1846 | (setq required-features (cdr required-features)))) | ||
| 1847 | |||
| 1848 | (setq current-language-environment language-name) | ||
| 1849 | (set-language-environment-coding-systems language-name default-eol-type)) | ||
| 1850 | (let ((input-method (get-language-info language-name 'input-method))) | ||
| 1851 | (when input-method | ||
| 1852 | (setq default-input-method input-method) | ||
| 1853 | (if input-method-history | ||
| 1854 | (setq input-method-history | ||
| 1855 | (cons input-method | ||
| 1856 | (delete input-method input-method-history)))))) | ||
| 1857 | (let ((nonascii (get-language-info language-name 'nonascii-translation)) | ||
| 1858 | (dos-table | ||
| 1859 | (if (eq window-system 'pc) | ||
| 1860 | (intern | ||
| 1861 | (format "cp%d-nonascii-translation-table" dos-codepage))))) | ||
| 1862 | (cond | ||
| 1863 | ((char-table-p nonascii) | ||
| 1864 | (setq nonascii-translation-table nonascii)) | ||
| 1865 | ((and (eq window-system 'pc) (boundp dos-table)) | ||
| 1866 | ;; DOS terminals' default is to use a special non-ASCII translation | ||
| 1867 | ;; table as appropriate for the installed codepage. | ||
| 1868 | (setq nonascii-translation-table (symbol-value dos-table))) | ||
| 1869 | ((charsetp nonascii) | ||
| 1870 | (setq nonascii-insert-offset (- (make-char nonascii) 128))))) | ||
| 1871 | |||
| 1872 | ;; Unibyte setups if necessary. | ||
| 1873 | (unless default-enable-multibyte-characters | ||
| 1874 | ;; Syntax and case table. | ||
| 1875 | (let ((syntax (get-language-info language-name 'unibyte-syntax))) | ||
| 1876 | (if syntax | ||
| 1877 | (let ((set-case-syntax-set-multibyte nil)) | ||
| 1878 | (load syntax nil t)) | ||
| 1879 | ;; No information for syntax and case. Reset to the defaults. | ||
| 1880 | (let ((syntax-table (standard-syntax-table)) | ||
| 1881 | (standard-table (standard-case-table)) | ||
| 1882 | (case-table (make-char-table 'case-table)) | ||
| 1883 | (ch (if (eq window-system 'pc) 128 160))) | ||
| 1884 | (while (< ch 256) | ||
| 1885 | (modify-syntax-entry ch " " syntax-table) | ||
| 1886 | (setq ch (1+ ch))) | ||
| 1887 | (dotimes (i 128) | ||
| 1888 | (aset case-table i (aref standard-table i))) | ||
| 1889 | (set-char-table-extra-slot case-table 0 nil) | ||
| 1890 | (set-char-table-extra-slot case-table 1 nil) | ||
| 1891 | (set-char-table-extra-slot case-table 2 nil) | ||
| 1892 | (set-standard-case-table case-table)) | ||
| 1893 | (let ((list (buffer-list))) | ||
| 1894 | (while list | ||
| 1895 | (with-current-buffer (car list) | ||
| 1896 | (set-case-table (standard-case-table))) | ||
| 1897 | (setq list (cdr list)))))) | ||
| 1898 | (set-display-table-and-terminal-coding-system language-name)) | ||
| 1899 | 1850 | ||
| 1851 | (reset-language-environment) | ||
| 1852 | ;; The features might set up coding systems. | ||
| 1900 | (let ((required-features (get-language-info language-name 'features))) | 1853 | (let ((required-features (get-language-info language-name 'features))) |
| 1901 | (while required-features | 1854 | (while required-features |
| 1902 | (require (car required-features)) | 1855 | (require (car required-features)) |
| 1903 | (setq required-features (cdr required-features)))) | 1856 | (setq required-features (cdr required-features)))) |
| 1904 | 1857 | ||
| 1905 | ;; Don't invoke fontset-related functions if fontsets aren't | 1858 | (setq current-language-environment language-name) |
| 1906 | ;; supported in this build of Emacs. | 1859 | |
| 1907 | (when (fboundp 'fontset-list) | 1860 | (set-language-environment-coding-systems language-name) |
| 1908 | (let ((overriding-fontspec (get-language-info language-name | 1861 | (set-language-environment-input-method language-name) |
| 1909 | 'overriding-fontspec))) | 1862 | (set-language-environment-nonascii-translation language-name) |
| 1910 | (if overriding-fontspec | 1863 | (set-language-environment-charset language-name) |
| 1911 | (set-overriding-fontspec-internal overriding-fontspec)))) | 1864 | (set-language-environment-fontset language-name) |
| 1865 | ;; Unibyte setups if necessary. | ||
| 1866 | (unless default-enable-multibyte-characters | ||
| 1867 | (set-language-environment-unibyte language-name)) | ||
| 1912 | 1868 | ||
| 1913 | (let ((func (get-language-info language-name 'setup-function))) | 1869 | (let ((func (get-language-info language-name 'setup-function))) |
| 1914 | (if (functionp func) | 1870 | (if (functionp func) |
| 1915 | (funcall func))) | 1871 | (funcall func))) |
| 1916 | (if (and utf-translate-cjk-mode | 1872 | |
| 1917 | (not (eq utf-translate-cjk-lang-env language-name)) | ||
| 1918 | (catch 'tag | ||
| 1919 | (dolist (charset (get-language-info language-name 'charset)) | ||
| 1920 | (if (memq charset utf-translate-cjk-charsets) | ||
| 1921 | (throw 'tag t))) | ||
| 1922 | nil)) | ||
| 1923 | (utf-translate-cjk-load-tables)) | ||
| 1924 | (run-hooks 'set-language-environment-hook) | 1873 | (run-hooks 'set-language-environment-hook) |
| 1925 | (force-mode-line-update t)) | 1874 | (force-mode-line-update t)) |
| 1926 | 1875 | ||
| @@ -1949,14 +1898,11 @@ specifies the character set for the major languages of Western Europe." | |||
| 1949 | ;; proper windows-1252 coding system. --fx] | 1898 | ;; proper windows-1252 coding system. --fx] |
| 1950 | (aset standard-display-table 146 [39])))) | 1899 | (aset standard-display-table 146 [39])))) |
| 1951 | 1900 | ||
| 1952 | (defun set-language-environment-coding-systems (language-name | 1901 | (defun set-language-environment-coding-systems (language-name) |
| 1953 | &optional eol-type) | 1902 | "Do various coding system setups for language environment LANGUAGE-NAME." |
| 1954 | "Do various coding system setups for language environment LANGUAGE-NAME. | ||
| 1955 | |||
| 1956 | The optional arg EOL-TYPE specifies the eol-type of the default value | ||
| 1957 | of `buffer-file-coding-system' set by this function." | ||
| 1958 | (let* ((priority (get-language-info language-name 'coding-priority)) | 1903 | (let* ((priority (get-language-info language-name 'coding-priority)) |
| 1959 | (default-coding (car priority))) | 1904 | (default-coding (car priority)) |
| 1905 | (eol-type (coding-system-eol-type default-buffer-file-coding-system))) | ||
| 1960 | (if priority | 1906 | (if priority |
| 1961 | (let ((categories (mapcar 'coding-system-category priority))) | 1907 | (let ((categories (mapcar 'coding-system-category priority))) |
| 1962 | (set-default-coding-systems | 1908 | (set-default-coding-systems |
| @@ -1971,6 +1917,80 @@ of `buffer-file-coding-system' set by this function." | |||
| 1971 | ;; Changing the binding of a coding category requires this call. | 1917 | ;; Changing the binding of a coding category requires this call. |
| 1972 | (update-coding-systems-internal))))) | 1918 | (update-coding-systems-internal))))) |
| 1973 | 1919 | ||
| 1920 | (defun set-language-environment-input-method (language-name) | ||
| 1921 | "Do various input method setups for language environment LANGUAGE-NAME." | ||
| 1922 | (let ((input-method (get-language-info language-name 'input-method))) | ||
| 1923 | (when input-method | ||
| 1924 | (setq default-input-method input-method) | ||
| 1925 | (if input-method-history | ||
| 1926 | (setq input-method-history | ||
| 1927 | (cons input-method | ||
| 1928 | (delete input-method input-method-history))))))) | ||
| 1929 | |||
| 1930 | (defun set-language-environment-nonascii-translation (language-name) | ||
| 1931 | "Do unibyte/multibyte translation setup for language environment LANGUAGE-NAME." | ||
| 1932 | (let ((nonascii (get-language-info language-name 'nonascii-translation)) | ||
| 1933 | (dos-table | ||
| 1934 | (if (eq window-system 'pc) | ||
| 1935 | (intern | ||
| 1936 | (format "cp%d-nonascii-translation-table" dos-codepage))))) | ||
| 1937 | (cond | ||
| 1938 | ((char-table-p nonascii) | ||
| 1939 | (setq nonascii-translation-table nonascii)) | ||
| 1940 | ((and (eq window-system 'pc) (boundp dos-table)) | ||
| 1941 | ;; DOS terminals' default is to use a special non-ASCII translation | ||
| 1942 | ;; table as appropriate for the installed codepage. | ||
| 1943 | (setq nonascii-translation-table (symbol-value dos-table))) | ||
| 1944 | ((charsetp nonascii) | ||
| 1945 | (setq nonascii-insert-offset (- (make-char nonascii) 128)))))) | ||
| 1946 | |||
| 1947 | (defun set-language-environment-charset (language-name) | ||
| 1948 | "Do various charset setups for language environment LANGUAGE-NAME." | ||
| 1949 | (if (and utf-translate-cjk-mode | ||
| 1950 | (not (eq utf-translate-cjk-lang-env language-name)) | ||
| 1951 | (catch 'tag | ||
| 1952 | (dolist (charset (get-language-info language-name 'charset)) | ||
| 1953 | (if (memq charset utf-translate-cjk-charsets) | ||
| 1954 | (throw 'tag t))) | ||
| 1955 | nil)) | ||
| 1956 | (utf-translate-cjk-load-tables))) | ||
| 1957 | |||
| 1958 | (defun set-language-environment-fontset (language-name) | ||
| 1959 | "Do various fontset setups for language environment LANGUAGE-NAME." | ||
| 1960 | ;; Don't invoke fontset-related functions if fontsets aren't | ||
| 1961 | ;; supported in this build of Emacs. | ||
| 1962 | (if (fboundp 'fontset-list) | ||
| 1963 | (set-overriding-fontspec-internal | ||
| 1964 | (get-language-info language-name 'overriding-fontspec)))) | ||
| 1965 | |||
| 1966 | (defun set-language-environment-unibyte (language-name) | ||
| 1967 | "Do various unibyte-mode setups for language environment LANGUAGE-NAME." | ||
| 1968 | ;; Syntax and case table. | ||
| 1969 | (let ((syntax (get-language-info language-name 'unibyte-syntax))) | ||
| 1970 | (if syntax | ||
| 1971 | (let ((set-case-syntax-set-multibyte nil)) | ||
| 1972 | (load syntax nil t)) | ||
| 1973 | ;; No information for syntax and case. Reset to the defaults. | ||
| 1974 | (let ((syntax-table (standard-syntax-table)) | ||
| 1975 | (standard-table (standard-case-table)) | ||
| 1976 | (case-table (make-char-table 'case-table)) | ||
| 1977 | (ch (if (eq window-system 'pc) 128 160))) | ||
| 1978 | (while (< ch 256) | ||
| 1979 | (modify-syntax-entry ch " " syntax-table) | ||
| 1980 | (setq ch (1+ ch))) | ||
| 1981 | (dotimes (i 128) | ||
| 1982 | (aset case-table i (aref standard-table i))) | ||
| 1983 | (set-char-table-extra-slot case-table 0 nil) | ||
| 1984 | (set-char-table-extra-slot case-table 1 nil) | ||
| 1985 | (set-char-table-extra-slot case-table 2 nil) | ||
| 1986 | (set-standard-case-table case-table)) | ||
| 1987 | (let ((list (buffer-list))) | ||
| 1988 | (while list | ||
| 1989 | (with-current-buffer (car list) | ||
| 1990 | (set-case-table (standard-case-table))) | ||
| 1991 | (setq list (cdr list)))))) | ||
| 1992 | (set-display-table-and-terminal-coding-system language-name)) | ||
| 1993 | |||
| 1974 | (defsubst princ-list (&rest args) | 1994 | (defsubst princ-list (&rest args) |
| 1975 | "Print all arguments with `princ', then print \"\n\"." | 1995 | "Print all arguments with `princ', then print \"\n\"." |
| 1976 | (while args (princ (car args)) (setq args (cdr args))) | 1996 | (while args (princ (car args)) (setq args (cdr args))) |