Mercurial > emacs

changeset 20840:1842af0263da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Many codes re-written to adjust for character-base positioning and for speed up by using with-temp-file, with-temp-buffer, and princ.
author Kenichi Handa <handa@m17n.org>
date Wed, 04 Feb 1998 11:25:47 +0000
parents e933240ee6c0
children ef5fd882ca63
files lisp/international/titdic-cnv.el
diffstat 1 files changed, 173 insertions(+), 200 deletions(-) [+]
line wrap: on
line diff
--- 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)