Initial revision

lisp/gnus/gnus-mule.el

+;; gnus-mule.el -- Provide multilingual environment to GNUS
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: gnus, mule
+
+;; This file is part of GNU Emacs.
+
+;; 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 2, 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This package enables GNUS to code convert automatically
+;; accoding to a coding system specified for each news group.
+;; Please put the following line in your .emacs:
+;;	(add-hook 'gnus-startup-hook 'gnus-mule-initialize)
+;; If you want to specify some coding system for a specific news
+;; group, add the fllowing line in your .emacs:
+;;	(gnus-mule-add-group "xxx.yyy.zzz" 'some-coding-system)
+;;
+;; Decoding of summary buffer is not yet implemented.
+
+(require 'gnus)
+
+(defvar gnus-newsgroup-coding-systems nil
+  "Assoc list of news groups vs corresponding coding systems.
+Each element is a list of news group name and cons of coding systems
+for reading and posting.")
+
+;;;###autoload
+(defun gnus-mule-add-group (name coding-system)
+  "Specify that articles of news group NAME are encoded in CODING-SYSTEM.
+All news groups deeper than NAME are also the target.
+If CODING-SYSTEM is a cons, the car and cdr part are regarded as
+coding-system for reading and writing respectively."
+  (if (not (consp coding-system))
+      (setq coding-system (cons coding-system coding-system)))
+  (setq name (concat "^" (regexp-quote name)))
+  (let ((group (assoc name gnus-newsgroup-coding-systems)))
+    (if group
+	(setcdr group coding-system)
+      (setq gnus-newsgroup-coding-systems
+	    (cons (cons name coding-system) gnus-newsgroup-coding-systems)))))
+
+(defun gnus-mule-get-coding-system (group)
+  "Return the coding system for news group GROUP."
+  (let ((groups gnus-newsgroup-coding-systems)
+	(len -1)
+	coding-system)
+    ;; Find an entry which matches GROUP the best (i.e. longest).
+    (while groups
+      (if (and (string-match (car (car groups)) group)
+	       (> (match-end 0) len))
+	  (setq len (match-end 0)
+		coding-system (cdr (car groups))))
+      (setq groups (cdr groups)))
+    coding-system))
+
+;; Flag to indicate if article buffer is already decoded or not.")
+(defvar gnus-mule-article-decoded nil)
+;; Codingsystem for reading articles of the current news group.
+(defvar gnus-mule-coding-system nil)
+(defvar gnus-mule-subject nil)
+(defvar gnus-mule-decoded-subject nil)
+(defvar gnus-mule-original-subject nil)
+
+;; Encode (if ENCODING is t) or decode (if ENCODING is nil)  the
+;; region from START to END by CODING-SYSTEM.
+(defun gnus-mule-code-convert1 (start end coding-system encoding)
+  (if (< start end)
+      (save-excursion
+       (if encoding
+	   (encode-coding-region start end coding-system)
+	 (decode-coding-region start end coding-system)))))
+
+;; Encode (if ENCODING is t) or decode (if ENCODING is nil) the
+;; current buffer by CODING-SYSTEM.  Try not to move positions of
+;; (window-start) and (point).
+(defun gnus-mule-code-convert (coding-system encoding)
+  (if coding-system
+      (let ((win (get-buffer-window (current-buffer))))
+	(if win
+	    ;; We should keep (point) and (window-start).
+	    (save-window-excursion
+	      (select-window win)
+	      (if encoding
+		  ;; Simple way to assure point is on valid character boundary.
+		  (beginning-of-line))
+	      (gnus-mule-code-convert1 (point-min) (window-start)
+				       coding-system encoding)
+	      (gnus-mule-code-convert1 (window-start) (point)
+				       coding-system encoding)
+	      (gnus-mule-code-convert1 (point) (point-max)
+				       coding-system encoding)
+	      (if (not (pos-visible-in-window-p))
+		  ;; point went out of window, move to the bottom of window.
+		  (move-to-window-line -1)))
+	  ;; No window for the buffer, no need to worry about (point)
+	  ;; and (windos-start).
+	  (gnus-mule-code-convert1 (point-min) (point-max)
+				   coding-system encoding))
+	)))
+
+;; Set `gnus-mule-coding-system' to the coding system articles of the
+;; current news group is encoded.   This function is set in
+;; `gnus-select-group-hook'.
+(defun gnus-mule-select-coding-system ()
+  (let ((coding-system (gnus-mule-get-coding-system gnus-newsgroup-name)))
+    (setq gnus-mule-coding-system
+	  (if (and coding-system (coding-system-p (car coding-system)))
+	      (car coding-system)))))
+
+;; Decode the current article.  This function is set in
+;; `gnus-article-prepare-hook'.
+(defun gnus-mule-decode-article ()
+  (gnus-mule-code-convert gnus-mule-coding-system nil)
+  (setq gnus-mule-article-decoded t))
+
+;; Decode the current summary buffer.  This function is set in
+;; `gnus-summary-prepare-hook'. 
+(defun gnus-mule-decode-summary ()
+  ;; I have not yet implemented this function because I'm not yet
+  ;; familiar with the new Gnus codes, especialy how to extract only
+  ;; subjects from a summary buffer.
+  nil)
+
+(defun gnus-mule-toggle-article-format ()
+  "Toggle decoding/encoding of the current article buffer."
+  (interactive)
+  (let ((buf (get-buffer gnus-article-buffer)))
+    (if (and gnus-mule-coding-system buf)
+	(save-excursion
+	  (set-buffer buf)
+	  (let ((modif (buffer-modified-p))
+		buffer-read-only)
+	    (gnus-mule-code-convert gnus-mule-coding-system
+				   gnus-mule-article-decoded)
+	    (setq gnus-mule-article-decoded (not gnus-mule-article-decoded))
+	    (set-buffer-modified-p modif))))))
+
+;;;###autoload
+(defun gnus-mule-initialize ()
+  "Do several settings for GNUS to enable automatic code conversion."
+  ;; Convenient key definitions
+  (define-key gnus-article-mode-map "z" 'gnus-mule-toggle-article-format)
+  (define-key gnus-summary-mode-map "z" 'gnus-mule-toggle-article-format)
+  ;; Hook definition
+  (add-hook 'gnus-select-group-hook 'gnus-mule-select-coding-system)
+  (add-hook 'gnus-summary-prepare-hook 'gnus-mule-decode-summary)
+  (add-hook 'gnus-article-prepare-hook 'gnus-mule-decode-article))
+
+(gnus-mule-add-group "" 'coding-system-iso-2022-7) ;; default coding system
+(gnus-mule-add-group "alt" 'no-conversion)
+(gnus-mule-add-group "comp" 'no-conversion)
+(gnus-mule-add-group "gnu" 'no-conversion)
+(gnus-mule-add-group "rec" 'no-conversion)
+(gnus-mule-add-group "sci" 'no-conversion)
+(gnus-mule-add-group "soc" 'no-conversion)
+(gnus-mule-add-group "alt.chinese.text" 'coding-system-hz)
+(gnus-mule-add-group "alt.hk" 'coding-system-hz)
+(gnus-mule-add-group "alt.chinese.text.big5" 'coding-system-big5)
+(gnus-mule-add-group "soc.culture.vietnamese" '(nil . coding-system-viqr))
+
+(add-hook 'gnus-startup-hook 'gnus-mule-initialize)
+
+;; gnus-mule.el ends here

lisp/international/ccl.el

+;; ccl.el -- CCL (Code Conversion Language) compiler
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: CCL, mule, multilingual, character set, coding-system
+
+;; This file is part of GNU Emacs.
+
+;; 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 2, 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; CCL (Code Conversion Language) is a simple programming language to
+;; be used for various kind of code conversion.  CCL program is
+;; compiled to CCL code (vector of integers) and executed by CCL
+;; interpreter of Emacs.
+;;
+;; CCL is used for code conversion at process I/O and file I/O for
+;; non-standard coding-system.  In addition, it is used for
+;; calculating a code point of X's font from a character code.
+;; However, since CCL is designed as a powerful programming language,
+;; it can be used for more generic calculation.  For instance,
+;; combination of three or more arithmetic operations can be
+;; calculated faster than Emacs Lisp.
+;;
+;; Here's the syntax of CCL program in BNF notation.
+;;
+;; CCL_PROGRAM :=
+;;	(BUFFER_MAGNIFICATION
+;;	 CCL_MAIN_BLOCK
+;;	 [ CCL_EOF_BLOCK ])
+;;
+;; BUFFER_MAGNIFICATION := integer
+;; CCL_MAIN_BLOCK := CCL_BLOCK
+;; CCL_EOF_BLOCK := CCL_BLOCK
+;;
+;; CCL_BLOCK :=
+;;	STATEMENT | (STATEMENT [STATEMENT ...])
+;; STATEMENT :=
+;;	SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
+;;
+;; SET :=
+;;	(REG = EXPRESSION)
+;;	| (REG ASSIGNMENT_OPERATOR EXPRESSION)
+;;	| integer
+;;
+;; EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
+;;
+;; IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK)
+;; BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...])
+;; LOOP := (loop STATEMENT [STATEMENT ...])
+;; BREAK := (break)
+;; REPEAT :=
+;;	(repeat)
+;;	| (write-repeat [REG | integer | string])
+;;	| (write-read-repeat REG [integer | ARRAY])
+;; READ :=
+;;	(read REG ...)
+;;	| (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK)
+;;	| (read-branch REG CCL_BLOCK [CCL_BLOCK ...])
+;; WRITE :=
+;;	(write REG ...)
+;;	| (write EXPRESSION)
+;;	| (write integer) | (write string) | (write REG ARRAY)
+;;	| string
+;; CALL := (call ccl-program-name)
+;; END := (end)
+;;
+;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
+;; ARG := REG | integer
+;; OPERATOR :=
+;;	+ | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
+;;	| < | > | == | <= | >= | != | de-sjis | en-sjis
+;; ASSIGNMENT_OPERATOR :=
+;;	+= | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
+;; ARRAY := '[' interger ... ']'
+
+;;; Code:
+
+(defconst ccl-command-table
+  [if branch loop break repeat write-repeat write-read-repeat
+      read read-if read-branch write call end]
+  "*Vector of CCL commands (symbols).")
+
+;; Put a property to each symbol of CCL commands for the compiler.
+(let (op (i 0) (len (length ccl-command-table)))
+  (while (< i len)
+    (setq op (aref ccl-command-table i))
+    (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
+    (setq i (1+ i))))
+
+(defconst ccl-code-table
+  [set-register
+   set-short-const
+   set-const
+   set-array
+   jump
+   jump-cond
+   write-register-jump
+   write-register-read-jump
+   write-const-jump
+   write-const-read-jump
+   write-string-jump
+   write-array-read-jump
+   read-jump
+   branch
+   read-register
+   write-expr-const
+   read-branch
+   write-register
+   write-expr-register
+   call
+   write-const-string
+   write-array
+   end
+   set-assign-expr-const
+   set-assign-expr-register
+   set-expr-const
+   set-expr-register
+   jump-cond-expr-const
+   jump-cond-expr-register
+   read-jump-cond-expr-const
+   read-jump-cond-expr-register
+   ]
+  "*Vector of CCL compiled codes (symbols).")
+
+;; Put a property to each symbol of CCL codes for the disassembler.
+(let (code (i 0) (len (length ccl-code-table)))
+  (while (< i len)
+    (setq code (aref ccl-code-table i))
+    (put code 'ccl-code i)
+    (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
+    (setq i (1+ i))))
+
+(defconst ccl-jump-code-list
+  '(jump jump-cond write-register-jump write-register-read-jump
+    write-const-jump write-const-read-jump write-string-jump
+    write-array-read-jump read-jump))
+
+;; Put a property `jump-flag' to each CCL code which execute jump in
+;; some way.
+(let ((l ccl-jump-code-list))
+  (while l
+    (put (car l) 'jump-flag t)
+    (setq l (cdr l))))
+
+(defconst ccl-register-table
+  [r0 r1 r2 r3 r4 r5 r6 r7]
+  "*Vector of CCL registers (symbols).")
+
+;; Put a property to indicate register number to each symbol of CCL.
+;; registers.
+(let (reg (i 0) (len (length ccl-register-table)))
+  (while (< i len)
+    (setq reg (aref ccl-register-table i))
+    (put reg 'ccl-register-number i)
+    (setq i (1+ i))))
+
+(defconst ccl-arith-table
+  [+ - * / % & | ^ << >> <8 >8 // nil nil nil
+   < > == <= >= != de-sjis en-sjis]
+  "*Vector of CCL arithmetic/logical operators (symbols).")
+
+;; Put a property to each symbol of CCL operators for the compiler.
+(let (arith (i 0) (len (length ccl-arith-table)))
+  (while (< i len)
+    (setq arith (aref ccl-arith-table i))
+    (if arith (put arith 'ccl-arith-code i))
+    (setq i (1+ i))))
+
+(defconst ccl-assign-arith-table
+  [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
+  "*Vector of CCL assignment operators (symbols).")
+
+;; Put a property to each symbol of CCL assignment operators for the compiler.
+(let (arith (i 0) (len (length ccl-assign-arith-table)))
+  (while (< i len)
+    (setq arith (aref ccl-assign-arith-table i))
+    (put arith 'ccl-self-arith-code i)
+    (setq i (1+ i))))
+
+(defvar ccl-program-vector nil
+  "Working vector of CCL codes produced by CCL compiler.")
+(defvar ccl-current-ic 0
+  "The current index for `ccl-program-vector'.")
+
+;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
+;; increment it.  If IC is specified, embed DATA at IC.
+(defun ccl-embed-data (data &optional ic)
+  (if ic
+      (aset ccl-program-vector ic data)
+    (aset ccl-program-vector ccl-current-ic data)
+    (setq ccl-current-ic (1+ ccl-current-ic))))
+
+;; Embed string STR of length LEN in `ccl-program-vector' at
+;; `ccl-current-ic'.
+(defun ccl-embed-string (len str)
+  (let ((i 0))
+    (while (< i len)
+      (ccl-embed-data (logior (ash (aref str i) 16)
+			       (if (< (1+ i) len)
+				   (ash (aref str (1+ i)) 8)
+				 0)
+			       (if (< (+ i 2) len)
+				   (aref str (+ i 2))
+				 0)))
+      (setq i (+ i 3)))))
+
+;; Embed a relative jump address to `ccl-current-ic' in
+;; `ccl-program-vector' at IC without altering the other bit field.
+(defun ccl-embed-current-address (ic)
+  (let ((relative (- ccl-current-ic (1+ ic))))
+    (aset ccl-program-vector ic
+	  (logior (aref ccl-program-vector ic) (ash relative 8)))))
+
+;; Embed CCL code for the operation OP and arguments REG and DATA in
+;; `ccl-program-vector' at `ccl-current-ic' in the following format.
+;;	|----------------- integer (28-bit) ------------------|
+;;	|------------ 20-bit ------------|- 3-bit --|- 5-bit -|
+;;	|------------- DATA -------------|-- REG ---|-- OP ---|
+;; If REG2 is specified, embed a code in the following format.
+;;	|------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
+;;	|-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
+
+;; If REG is a CCL register symbol (e.g. r0, r1...), the register
+;; number is embedded.  If OP is one of unconditional jumps, DATA is
+;; changed to an absolute jump address.
+
+(defun ccl-embed-code (op reg data &optional reg2)
+  (if (and (> data 0) (get op 'jump-flag))
+      ;; DATA is an absolute jump address.  Make it relative to the
+      ;; next of jump code.
+      (setq data (- data (1+ ccl-current-ic))))
+  (let ((code (logior (get op 'ccl-code)
+		      (ash
+		       (if (symbolp reg) (get reg 'ccl-register-number) reg) 5)
+		      (if reg2
+			  (logior (ash (get reg2 'ccl-register-number) 8)
+				  (ash data 11))
+			(ash data 8)))))
+    (aset ccl-program-vector ccl-current-ic code)
+    (setq ccl-current-ic (1+ ccl-current-ic))))
+
+;; Just advance `ccl-current-ic' by INC.
+(defun ccl-increment-ic (inc)
+  (setq ccl-current-ic (+ ccl-current-ic inc)))
+
+;;;###autoload
+(defun ccl-program-p (obj)
+  "T if OBJECT is a valid CCL compiled code."
+  (and (vectorp obj)
+       (let ((i 0) (len (length obj)) (flag t))
+	 (if (> len 1)
+	     (progn
+	       (while (and flag (< i len))
+		 (setq flag (integerp (aref obj i)))
+		 (setq i (1+ i)))
+	       flag)))))
+
+;; If non-nil, index of the start of the current loop.
+(defvar ccl-loop-head nil)
+;; If non-nil, list of absolute addresses of the breaking points of
+;; the current loop.
+(defvar ccl-breaks nil)
+
+;;;###autoload
+(defun ccl-compile (ccl-program)
+  "Return a comiled code of CCL-PROGRAM as a vector of integer."
+  (if (or (null (consp ccl-program))
+	  (null (integerp (car ccl-program)))
+	  (null (listp (car (cdr ccl-program)))))
+      (error "CCL: Invalid CCL program: %s" ccl-program))
+  (if (null (vectorp ccl-program-vector))
+      (setq ccl-program-vector (make-vector 8192 0)))
+  (setq ccl-loop-head nil ccl-breaks nil)
+  (setq ccl-current-ic 0)
+
+  ;; The first element is the buffer magnification.
+  (ccl-embed-data (car ccl-program))
+
+  ;; The second element is the address of the start CCL code for
+  ;; processing end of input buffer (we call it eof-processor).  We
+  ;; set it later.
+  (ccl-increment-ic 1)
+
+  ;; Compile the main body of the CCL program.
+  (ccl-compile-1 (car (cdr ccl-program)))
+
+  ;; Embed the address of eof-processor.
+  (ccl-embed-data ccl-current-ic 1)
+
+  ;; Then compile eof-processor.
+  (if (nth 2 ccl-program)
+      (ccl-compile-1 (nth 2 ccl-program)))
+
+  ;; At last, embed termination code.
+  (ccl-embed-code 'end 0 0)
+
+  (let ((vec (make-vector ccl-current-ic 0))
+	(i 0))
+    (while (< i ccl-current-ic)
+      (aset vec i (aref ccl-program-vector i))
+      (setq i (1+ i)))
+    vec))
+
+;; Signal syntax error.
+(defun ccl-syntax-error (cmd)
+  (error "CCL: Syntax error: %s" cmd))
+
+;; Check if ARG is a valid CCL register.
+(defun ccl-check-register (arg cmd)
+  (if (get arg 'ccl-register-number)
+      arg
+    (error "CCL: Invalid register %s in %s." arg cmd)))
+
+;; Check if ARG is a valid CCL command.
+(defun ccl-check-compile-function (arg cmd)
+  (or (get arg 'ccl-compile-function)
+      (error "CCL: Invalid command: %s" cmd)))
+
+;; In the following code, most ccl-compile-XXXX functions return t if
+;; they end with unconditional jump, else return nil.
+
+;; Compile CCL-BLOCK (see the syntax above).
+(defun ccl-compile-1 (ccl-block)
+  (let (unconditional-jump
+	cmd)
+    (if (or (integerp ccl-block)
+	    (stringp ccl-block)
+	    (and ccl-block (symbolp (car ccl-block))))
+	;; This block consists of single statement.
+	(setq ccl-block (list ccl-block)))
+
+    ;; Now CCL-BLOCK is a list of statements.  Compile them one by
+    ;; one.
+    (while ccl-block
+      (setq cmd (car ccl-block))
+      (setq unconditional-jump
+	    (cond ((integerp cmd)
+		   ;; SET statement for the register 0.
+		   (ccl-compile-set (list 'r0 '= cmd)))
+
+		  ((stringp cmd)
+		   ;; WRITE statement of string argument.
+		   (ccl-compile-write-string cmd))
+
+		  ((listp cmd)
+		   ;; The other statements.
+		   (cond ((eq (nth 1 cmd) '=)
+			  ;; SET statement of the form `(REG = EXPRESSION)'.
+			  (ccl-compile-set cmd))
+
+			 ((and (symbolp (nth 1 cmd))
+			       (get (nth 1 cmd) 'ccl-self-arith-code))
+			  ;; SET statement with an assignment operation.
+			  (ccl-compile-self-set cmd))
+
+			 (t
+			  (funcall (ccl-check-compile-function (car cmd) cmd)
+				   cmd))))
+
+		  (t
+		   (ccl-syntax-error cmd))))
+      (setq ccl-block (cdr ccl-block)))
+    unconditional-jump))
+
+(defconst ccl-max-short-const (ash 1 19))
+(defconst ccl-min-short-const (ash -1 19))
+
+;; Compile SET statement.
+(defun ccl-compile-set (cmd)
+  (let ((rrr (ccl-check-register (car cmd) cmd))
+	(right (nth 2 cmd)))
+    (cond ((listp right)
+	   ;; CMD has the form `(RRR = (XXX OP YYY))'.
+	   (ccl-compile-expression rrr right))
+
+	  ((integerp right)
+	   ;; CMD has the form `(RRR = integer)'.
+	   (if (and (<= right ccl-max-short-const)
+		    (>= right ccl-min-short-const))
+	       (ccl-embed-code 'set-short-const rrr right)
+	     (ccl-embed-code 'set-const rrr 0)
+	     (ccl-embed-data right)))
+
+	  (t
+	   ;; CMD has the form `(RRR = rrr [ array ])'.
+	   (ccl-check-register right cmd)
+	   (let ((ary (nth 3 cmd)))
+	     (if (vectorp ary)
+		 (let ((i 0) (len (length ary)))
+		   (ccl-embed-code 'set-array rrr len right)
+		   (while (< i len)
+		     (ccl-embed-data (aref ary i))
+		     (setq i (1+ i))))
+	       (ccl-embed-code 'set-register rrr 0 right))))))
+  nil)
+
+;; Compile SET statement with ASSIGNMENT_OPERATOR.
+(defun ccl-compile-self-set (cmd)
+  (let ((rrr (ccl-check-register (car cmd) cmd))
+	(right (nth 2 cmd)))
+    (if (listp right)
+	;; CMD has the form `(RRR ASSIGN_OP (XXX OP YYY))', compile
+	;; the right hand part as `(r7 = (XXX OP YYY))' (note: the
+	;; register 7 can be used for storing temporary value).
+	(progn
+	  (ccl-compile-expression 'r7 right)
+	  (setq right 'r7)))
+    ;; Now CMD has the form `(RRR ASSIGN_OP ARG)'.  Compile it as
+    ;; `(RRR = (RRR OP ARG))'.
+    (ccl-compile-expression
+     rrr
+     (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
+  nil)
+