# HG changeset patch # User Kenichi Handa # Date 886591547 0 # Node ID 1842af0263da637d0380963e3cf38560ec59ce8a # Parent e933240ee6c0cd07776fbdc058978cc0f4fcb0a8 Many codes re-written to adjust for character-base positioning and for speed up by using with-temp-file, with-temp-buffer, and princ. diff -r e933240ee6c0 -r 1842af0263da lisp/international/titdic-cnv.el --- a/lisp/international/titdic-cnv.el Wed Feb 04 11:25:01 1998 +0000 +++ b/lisp/international/titdic-cnv.el Wed Feb 04 11:25:47 1998 +0000 @@ -96,8 +96,8 @@ (concat (file-name-nondirectory (substring filename 0 -4)) ".el") dirname)) -;; This value is t if we are processing phrase dictionary. -(defvar tit-phrase nil) +;; This value is nil if we are processing phrase dictionary. +(defconst tit-dictionary t) (defvar tit-encode nil) (defvar tit-default-encode "GB") @@ -106,18 +106,22 @@ (defun tit-generate-key-bindings (keys function-symbol) (let ((len (length keys)) (i 0) + (first t) key) (while (< i len) + (or first (princ "\n ")) (setq key (aref keys i)) - (indent-to 3) - (if (< key ?\ ) - (if (eq (lookup-key quail-translation-keymap (char-to-string key)) + (if (if (< key ?\ ) + (eq (lookup-key quail-translation-keymap + (char-to-string key)) 'quail-execute-non-quail-command) - (insert (format "(\"\\C-%c\" . %s)\n" - (+ key ?@) function-symbol))) - (if (< key 127) - (insert (format "(\"%c\" . %s)\n" key function-symbol)) - (insert (format "(\"\\C-?\" . %s)\n" function-symbol)))) + (<= key 127)) + (progn + (princ (cons (cond ((< key ?\ ) (format "\"\\C-%c\"" (+ key ?@))) + ((< key 127) (format "\"%c\"" key)) + (t "\"\\C-?\"")) + function-symbol)) + (setq first nil))) (setq i (1+ i))))) ;; Analyze header part of TIT dictionary and generate an appropriate @@ -126,7 +130,13 @@ (message "Processing header part...") (goto-char (point-min)) - (let (;; TIT keywords and the corresponding default values. + ;; At first, generate header part of the Quail package while + ;; collecting information from the original header. + (let ((package (concat + "chinese-" + (substring (downcase (file-name-nondirectory filename)) + 0 -4))) + ;; TIT keywords and the corresponding default values. (tit-multichoice t) (tit-prompt "") (tit-comments nil) @@ -135,18 +145,24 @@ (tit-moveright ".>") (tit-moveleft ",<") (tit-keyprompt nil)) - ;; At first, collect information from the header. + + (princ ";; Quail package `") + (princ package) + (princ "' generated by the command `titdic-convert'\n;;\tDate: ") + (princ (current-time-string)) + (princ "\n;;\tOriginal TIT dictionary file: ") + (princ (file-name-nondirectory filename)) + (princ "\n\n;;; Comment:\n\n") + (princ ";; Do byte-compile this file again after any modification.\n\n") + (princ ";;; Start of the header of original TIT dictionary.\n\n") + (while (not (eobp)) - (insert ";; ") - (let ((ch (following-char))) + (let ((ch (following-char)) + (pos (point))) (cond ((= ch ?C) ; COMMENT (cond ((looking-at "COMMENT") (let ((pos (match-end 0))) (end-of-line) - (while (re-search-backward "[\"\\]" pos t) - (insert "\\") - (forward-char -1)) - (end-of-line) (setq tit-comments (cons (buffer-substring pos (point)) tit-comments)))))) ((= ch ?M) ; MULTICHOICE, MOVERIGHT, MOVELEFT @@ -169,9 +185,9 @@ (goto-char (match-end 0)) (setq tit-backspace (tit-read-key-value))) ((looking-at "BEGINDICTIONARY") - (setq tit-phrase nil)) + (setq tit-dictionary t)) ((looking-at "BEGINPHRASE") - (setq tit-phrase t)))) + (setq tit-dictionary nil)))) ((= ch ?K) ; KEYPROMPT (cond ((looking-at "KEYPROMPT(\\(.*\\)):[ \t]*") (let ((key-char (match-string 1))) @@ -182,162 +198,132 @@ key-char))))) (setq tit-keyprompt (cons (cons key-char (tit-read-key-value)) - tit-keyprompt)))))))) - (forward-line 1)) + tit-keyprompt))))))) + (end-of-line) + (princ ";; ") + (princ (buffer-substring pos (point))) + (princ "\n") + (forward-line 1))) - ;; Then, generate header part of the Quail package. - (goto-char (point-min)) - (let ((package - (concat - "chinese-" - (substring (downcase (file-name-nondirectory buffer-file-name)) - 0 -3)))) - (insert ";; Quail package `" - package - "' generated by the command `titdic-convert'\n" - ";;\tDate: " (current-time-string) "\n" - ";;\tOriginal TIT dictionary file: " - (file-name-nondirectory filename) - "\n\n" - ";;; Comment:\n\n" - ";; Do byte-compile this file again after any modification.\n\n" - ";;; Start of the header of original TIT dictionary.\n\n") + (princ "\n;;; End of the header of original TIT dictionary.\n\n") + (princ ";;; Code:\n\n(require 'quail)\n\n") - (goto-char (point-max)) - (insert "\n" - ";;; End of the header of original TIT dictionary.\n\n" - ";;; Code:\n\n" - "(require 'quail)\n\n") - - (insert "(quail-define-package ") - ;; Args NAME, LANGUAGE, TITLE - (let ((title (cdr (assoc package quail-cxterm-package-title-alist)))) - (insert - "\"" - package - "\" \"" (nth 2 (assoc tit-encode tit-encode-list)) - "\" \"" - (or title - (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt) - (substring tit-prompt (match-beginning 1) (match-end 1)) - tit-prompt)) - "\"\n")) - ) + (princ "(quail-define-package ") + ;; Args NAME, LANGUAGE, TITLE + (let ((title (cdr (assoc package quail-cxterm-package-title-alist)))) + (princ "\"") + (princ package) + (princ "\" \"") + (princ (nth 2 (assoc tit-encode tit-encode-list))) + (princ "\" \"") + (princ (or title + (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt) + (substring tit-prompt (match-beginning 1) (match-end 1)) + tit-prompt))) + (princ "\"\n")) ;; Arg GUIDANCE (if tit-keyprompt (progn - (insert " '(") + (princ " '(") (while tit-keyprompt - (indent-to 3) - (insert (format "(%d . \"%s\")\n" - (string-to-char (car (car tit-keyprompt))) - (cdr (car tit-keyprompt)))) + (princ " ") + (princ (format "(%d . \"%s\")\n" + (string-to-char (car (car tit-keyprompt))) + (cdr (car tit-keyprompt)))) (setq tit-keyprompt (cdr tit-keyprompt))) - (forward-char -1) - (insert ")") - (forward-char 1)) - (insert " t\n")) + (princ ")")) + (princ " t\n")) ;; Arg DOCSTRING - (insert "\"" tit-prompt "\n") - (let ((l (nreverse tit-comments))) - (while l - (insert (format "%s\n" (car l))) - (setq l (cdr l)))) - (insert "\"\n") + (prin1 + (mapconcat 'identity (cons tit-prompt (nreverse tit-comments)) "\n")) + (terpri) ;; Arg KEY-BINDINGS - (insert " '(") + (princ " '(") (tit-generate-key-bindings tit-backspace 'quail-delete-last-char) + (princ "\n ") (tit-generate-key-bindings tit-deleteall 'quail-abort-translation) + (princ "\n ") (tit-generate-key-bindings tit-moveright 'quail-next-translation) + (princ "\n ") (tit-generate-key-bindings tit-moveleft 'quail-prev-translation) - (forward-char -1) - (insert ")") - (forward-char 1) + (princ ")\n") ;; Args FORGET-TRANSLATION, DETERMINISTIC, KBD-TRANSLATE, SHOW-LAYOUT. ;; The remaining args are all nil. - (insert " nil" - (if tit-multichoice " nil" " t") - (if tit-keyprompt " t t)\n\n" " nil nil)\n\n"))) + (princ " nil") + (princ (if tit-multichoice " nil" " t")) + (princ (if tit-keyprompt " t t)\n\n" " nil nil)\n\n")))) - ;; Return the position of end of the header. - (point-max)) +(defsubst tit-flush-translations (key translations) + (if (string-match "\\\\[0-9][0-9][0-9]" key) + (let ((newkey (concat (substring key 0 (match-beginning 0)) + (car (read-from-string + (concat "\"" (match-string 0 key) "\""))))) + (idx (match-end 0))) + (while (string-match "\\\\[0-9][0-9][0-9]" key idx) + (setq newkey (concat + newkey + (substring key idx (match-beginning 0)) + (car (read-from-string + (concat "\"" (match-string 0 key) "\""))))) + (setq idx (match-end 0))) + (setq key (concat newkey (substring key idx))))) + (prin1 (list key (if tit-dictionary translations + (vconcat (nreverse translations))))) + (princ "\n")) ;; Convert body part of TIT dictionary into `quail-define-rules' ;; function call. (defun tit-process-body () (message "Formatting translation rules...") - (let ((keyseq "\000") - pos) - (insert "(quail-define-rules\n") + (let* ((template (list nil nil)) + (second (cdr template)) + (prev-key "") + ch key translations pos) + (princ "(quail-define-rules\n") (while (null (eobp)) - (if (or (= (following-char) ?#) (= (following-char) ?\n)) - (progn - (insert ";; ") - (forward-line 1)) - (insert "(\"") - (setq pos (point)) - (skip-chars-forward "^ \t") - (setq keyseq - (concat (regexp-quote (buffer-substring pos (point))) "[ \t]+")) - (save-excursion - ;; Escape `"' and `\' which is not used for quoting the - ;; following octal digits. - (while (re-search-backward "\"\\|\\\\[^0-9]" pos t) - (insert "\\") - (forward-char -1))) - (insert "\"") - (skip-chars-forward " \t") - - ;; Now point is at the start of translations. Remember it in - ;; POS and combine lines of the same key sequence while - ;; deleting trailing white spaces and comments (start with - ;; '#'). POS doesn't has to be a marker because we never - ;; modify region before POS. + (setq ch (following-char)) + (if (or (= ch ?#) (= ch ?\n)) + (forward-line 1) (setq pos (point)) - (if (looking-at "[^ \t]*\\([ \t]*#.*\\)") - (delete-region (match-beginning 1) (match-end 1))) - (while (and (= (forward-line 1) 0) - (looking-at keyseq)) - (let ((p (match-end 0))) - (skip-chars-backward " \t\n") - (delete-region (point) p) - (if tit-phrase (insert " ")) - (if (looking-at "[^ \t]*\\([ \t]*#.*\\)") - (delete-region (match-beginning 1) (match-end 1))) - )) - - (goto-char pos) - (if (eolp) + (skip-chars-forward "^ \t\n") + (setq key (buffer-substring pos (point))) + (skip-chars-forward " \t") + (setq ch (following-char)) + (if (or (= ch ?#) (= ch ?\n)) ;; This entry contains no translations. Let's ignore it. - (progn - (beginning-of-line) + (forward-line 1) + (or (string= key prev-key) + (progn + (if translations + (tit-flush-translations prev-key translations)) + (setq translations nil + prev-key key))) + (if tit-dictionary + (progn + (setq pos (point)) + (skip-chars-forward "^ \t#\n") + (setq translations + (if translations + (concat translations + (buffer-substring pos (point))) + (buffer-substring pos (point))))) + (while (not (eolp)) (setq pos (point)) - (forward-line 1) - (delete-region pos (point))) + (skip-chars-forward "^ \t\n") + (setq translations (cons (buffer-substring pos (point)) + translations)) + (skip-chars-forward " \t") + (setq ch (following-char)) + (if (= ch ?#) (end-of-line)))) + (forward-line 1)))) - ;; Modify the current line to meet the syntax of Quail package. - (if tit-phrase - (progn - ;; PHRASE1 PHRASE2 ... => ["PHRASE1" "PHRASE2" ...] - (insert "[") - (skip-chars-forward " \t") - (while (not (eolp)) - (insert "\"") - (skip-chars-forward "^ \t\n") - (insert "\"") - (skip-chars-forward " \t")) - (insert "])")) - ;; TRANSLATIONS => "TRANSLATIONS" - (insert "\"") - (end-of-line) - (skip-chars-backward " \t") - (insert "\")")) - (forward-line 1)))) - (insert ")\n"))) + (if translations + (tit-flush-translations prev-key translations)) + (princ ")\n"))) ;;;###autoload (defun titdic-convert (filename &optional dirname) @@ -345,63 +331,50 @@ Optional argument DIRNAME if specified is the directory name under which the generated Quail package is saved." (interactive "FTIT dictionary file: ") - (let ((buf (get-buffer-create "*tit-work*"))) - (save-excursion - ;; Setup the buffer. - (set-buffer buf) - (erase-buffer) - (let ((coding-system-for-read 'no-conversion)) - (insert-file-contents (expand-file-name filename))) - (set-visited-file-name - (tit-make-quail-package-file-name filename dirname) t) - (setq enable-multibyte-characters t) - (set-buffer-file-coding-system 'iso-2022-7bit) + (with-temp-file (tit-make-quail-package-file-name filename dirname) + (set-buffer-file-coding-system 'iso-2022-7bit) + (let ((standard-output (current-buffer))) + (with-temp-buffer + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents (expand-file-name filename))) + (setq enable-multibyte-characters t) + + ;; Decode the buffer contents from the encoding specified by a + ;; value of the key "ENCODE:". + (if (not (search-forward "\nBEGIN" nil t)) + (error "TIT dictionary doesn't have body part")) + (let ((limit (point)) + coding-system slot) + (goto-char (point-min)) + (if (re-search-forward "^ENCODE:[ \t]*" limit t) + (progn + (goto-char (match-end 0)) + (setq tit-encode (tit-read-key-value))) + (setq tit-encode tit-default-encode)) + (setq slot (assoc tit-encode tit-encode-list)) + (if (not slot) + (error "Invalid ENCODE: value in TIT dictionary")) + (setq coding-system (nth 1 slot)) + (message "Decoding by %s..." coding-system) + (goto-char (point-min)) + (decode-coding-region (point-min) (point-max) coding-system)) - ;; Decode the buffer contents from the encoding specified by a - ;; value of the key "ENCODE:". - (let (coding-system) - (save-excursion - (if (search-forward "\nBEGIN" nil t) - (let ((limit (point)) - slot) - (goto-char 1) - (if (re-search-forward "^ENCODE:[ \t]*" limit t) - (progn - (goto-char (match-end 0)) - (setq tit-encode (tit-read-key-value))) - (setq tit-encode tit-default-encode)) - (setq slot (assoc tit-encode tit-encode-list)) - (if slot - (setq coding-system (nth 1 slot)) - (error "Invalid ENCODE: value in TIT dictionary"))) - (error "TIT dictionary doesn't have body part"))) - (message "Decoding %s..." coding-system) - (goto-char 1) - (decode-coding-region 1 (point-max) coding-system)) + ;; Set point the starting position of the body part. + (goto-char (point-min)) + (if (not (search-forward "\nBEGIN" nil t)) + (error "TIT dictionary can't be decoded correctly")) - ;; Set point the starting position of the body part. - (goto-char 1) - (if (search-forward "\nBEGIN" nil t) - (forward-line 1) - (error "TIT dictionary can't be decoded correctly")) + ;; Process the header part. + (forward-line 1) + (narrow-to-region (point-min) (point)) + (tit-process-header filename) + (widen) - ;; Now process the header and body parts. - (goto-char - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (tit-process-header filename)))) - (tit-process-body)) - - (if noninteractive - ;; Save the Quail package file. - (save-excursion - (set-buffer buf) - (save-buffer 0)) - ;; Show the Quail package just generated. - (switch-to-buffer buf) - (goto-char 1) - (message "Save this buffer after you make any modification")))) + ;; Process the body part. For speed, we turn off multibyte facility. + (with-current-buffer standard-output + (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) + (tit-process-body))))) ;;;###autoload (defun batch-titdic-convert (&optional force)