--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/mule/mule-ccl.el	Mon Aug 13 09:02:59 2007 +0200
@@ -0,0 +1,696 @@
+;;; mule-ccl.el --- Code Conversion Language functions.
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the 
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; 93.5.26  created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
+
+;;;; #### This stuff doesn't work yet.
+
+(defconst ccl-operator-table
+  '[if branch loop break repeat write-repeat write-read-repeat
+    read read-if read-branch write end])
+
+(let (op (i 0) (len (length ccl-operator-table)))
+  (while (< i len)
+    (setq op (aref ccl-operator-table i))
+    (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
+    (setq i (1+ i))))
+
+(defconst ccl-machine-code-table
+  '[set-cs set-cl set-r set-a
+    jump jump-cond write-jump write-read-jump write-c-jump
+    write-c-read-jump write-s-jump write-s-read-jump write-a-read-jump
+    branch
+    read1 read2 read-branch write1 write2 write-c write-s write-a
+    end
+    set-self-cs set-self-cl set-self-r set-expr-cl set-expr-r
+    jump-cond-c jump-cond-r read-jump-cond-c read-jump-cond-r
+    ])
+
+(let (code (i 0) (len (length ccl-machine-code-table)))
+  (while (< i len)
+    (setq code (aref ccl-machine-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-register-table '[r0 r1 r2 r3 r4 r5 r6 r7])
+
+(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 < > == <= >= !=])
+
+(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-self-arith-table
+  '[+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=])
+
+(let (arith (i 0) (len (length ccl-self-arith-table)))
+  (while (< i len)
+    (setq arith (aref ccl-self-arith-table i))
+    (put arith 'ccl-self-arith-code i)
+    (setq i (1+ i))))
+
+;; this holds the compiled CCL program as it is being compiled.
+(defvar ccl-program-vector nil)
+
+;; this holds the index into ccl-program-vector where the next
+;; instruction is to be stored.
+(defvar ccl-current-ic 0)
+
+;; add a constant to the compiled CCL program, either at IC (if specified)
+;; or at the current instruction counter (and bumping that value)
+(defun ccl-embed-const (const &optional ic)
+  (if ic
+      (aset ccl-program-vector ic const)
+    (aset ccl-program-vector ccl-current-ic const)
+    (setq ccl-current-ic (1+ ccl-current-ic))))
+
+(defun ccl-embed-code (op reg const &optional ic)
+  (let ((machine-code (logior (get op 'ccl-code)
+			      (if (symbolp reg)
+				  (ash (get reg 'ccl-register-number) 5)
+				0)
+			      (ash const 8))))
+    (if ic
+	(aset ccl-program-vector ic machine-code)
+      (aset ccl-program-vector ccl-current-ic machine-code)
+      (setq ccl-current-ic (1+ ccl-current-ic)))))
+
+;; advance the instruction counter by INC without doing anything else
+(defun ccl-embed-nop (&optional inc)
+  (setq ccl-current-ic (+ ccl-current-ic (or inc 1))))
+
+;;;###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)))))
+
+(defvar ccl-loop-head nil)
+(defvar ccl-breaks nil)
+
+;;;###autoload
+(defun ccl-compile (ccl-program)
+  "Compile a CCL source program and return the compiled equivalent.
+The return value will be a vector of integers."
+  (if (or (null (consp ccl-program))
+	  (null (listp (car ccl-program))))
+      (error "CCL: Invalid source program: %s" ccl-program))
+  (if (null (vectorp ccl-program-vector))
+      (setq ccl-program-vector (make-vector 8192 0))
+    ;; perhaps not necessary but guarantees some sort of determinism
+    (fillarray ccl-program-vector 0))
+  (setq ccl-loop-head nil ccl-breaks nil)
+  (setq ccl-current-ic 0)
+  ;; leave space for offset to EOL program
+  (ccl-embed-nop)
+  (ccl-compile-1 (car ccl-program))
+  ;; store offset to EOL program in first word of compiled prog
+  (ccl-embed-const ccl-current-ic 0)
+  (if (car (cdr ccl-program))
+      (ccl-compile-1 (car (cdr ccl-program))))
+  (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))
+
+(defun ccl-check-constant (arg cmd)
+  (if (>= arg 0)
+      arg
+    (error "CCL: Negative constant %s not allowed: %s" arg cmd)))
+
+(defun ccl-check-register (arg cmd)
+  (if (get arg 'ccl-register-number)
+      arg
+    (error "CCL: Invalid register %s: %s" arg cmd)))
+
+(defun ccl-check-reg-const (arg cmd)
+  (if (integer-or-char-p arg)
+      (ccl-check-constant arg cmd)
+    (ccl-check-register arg cmd)))
+
+(defun ccl-check-compile-function (arg cmd)
+  (or (get arg 'ccl-compile-function)
+      (error "CCL: Invalid command: %s" cmd)))
+
+;; compile a block of CCL code (see CCL_BLOCK above).
+(defun ccl-compile-1 (cmd-list)
+  (let (cmd)
+    ;; a CCL_BLOCK is either STATEMENT or (STATEMENT [STATEMENT ...])
+    ;; convert the former into the latter.
+    (if (or (not (listp cmd-list))
+	    (and cmd-list (symbolp (car cmd-list))))
+	(setq cmd-list (list cmd-list)))
+    (while cmd-list
+      (setq cmd (car cmd-list))
+      ;; an int-or-char is equivalent to (r0 = int-or-char)
+      ;; a string is equivalent to (write string)
+      ;; convert the above two into their equivalent forms.
+      ;; everything else is a list.
+      (cond ((integer-or-char-p cmd)
+	     (ccl-compile-set (list 'r0 '= cmd)))
+	    ((stringp cmd)
+	     (ccl-compile-write-string (list 'write cmd)))
+	    ((listp cmd)
+	     (if (eq (nth 1 cmd) '=)
+		 (ccl-compile-set cmd)
+	       (if (and (symbolp (nth 1 cmd))
+			(get (nth 1 cmd) 'ccl-self-arith-code))
+		   (ccl-compile-self-set cmd)
+		 (funcall (ccl-check-compile-function (car cmd) cmd) cmd))))
+	    (t
+	     (error "CCL: Invalid command: %s" cmd)))
+      (setq cmd-list (cdr cmd-list)))))
+
+(defun ccl-compile-set (cmd)
+  (let ((rrr (ccl-check-register (car cmd) cmd))
+	(right (nth 2 cmd)))
+    (cond ((listp right)
+	   ;; cmd == (RRR = (XXX OP YYY))
+	   (ccl-compile-expression rrr right))
+	  ((integer-or-char-p right)
+	   (ccl-check-constant right cmd)
+	   (if (< right 524288)		; (< right 2^19)
+	       (ccl-embed-code 'set-cs rrr right)
+	     (ccl-embed-code 'set-cl rrr 0)
+	     (ccl-embed-const right)))
+	  (t
+	   (ccl-check-register right cmd)
+	   (let ((ary (nth 3 cmd)))
+	     (if (vectorp ary)
+		 (let ((i 0) (len (length ary)))
+		   (ccl-embed-code 'set-a rrr (get right 'ccl-register-number))
+		   (ccl-embed-const len)
+		   (while (< i len)
+		     (ccl-check-constant (aref ary i) cmd)
+		     (ccl-embed-const (aref ary i))
+		     (setq i (1+ i))))
+	       (ccl-embed-code 'set-r rrr right)))))))
+
+(defun ccl-compile-self-set (cmd)
+  (let ((rrr (ccl-check-register (car cmd) cmd))
+	(right (nth 2 cmd)))
+    (if (listp right)
+	;; cmd == (RRR SELF-OP= (XXX OP YYY))
+	(progn
+	  (ccl-compile-expression 'r7 right)
+	  (setq right 'r7)))
+    (ccl-compile-expression
+     rrr
+     (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right))))
+
+(defun ccl-compile-expression (rrr expr)
+  (let ((left (car expr))
+	(right (nth 2 expr)))
+    (if (listp left)
+	(progn
+	  (ccl-compile-expression 'r7 left)
+	  (setq left 'r7)))
+    (if (eq rrr left)
+	(if (integer-or-char-p right)
+	    (if (< right 32768)
+		(ccl-embed-code 'set-self-cs rrr right)
+	      (ccl-embed-code 'set-self-cl rrr 0)
+	      (ccl-embed-const right))
+	  (ccl-check-register right expr)
+	  (ccl-embed-code 'set-self-r rrr (get right 'ccl-register-number)))
+      (if (integer-or-char-p right)
+	  (progn
+	    (ccl-embed-code 'set-expr-cl rrr (get left 'ccl-register-number))
+	    (ccl-embed-const right))
+	(ccl-check-register right expr)
+	(ccl-embed-code 'set-expr-r rrr (get left 'ccl-register-number))
+	(ccl-embed-const (get right 'ccl-register-number))))
+    (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code))))
+
+(defun ccl-compile-write-string (cmd)
+  (if (/= (length cmd) 2)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (let* ((str (nth 1 cmd))
+	 (len (length str))
+	 (i 0))
+    (ccl-embed-code 'write-s 0 0)
+    (ccl-embed-const len)
+    (while (< i len)
+      (ccl-embed-const (aref str i))
+      (setq i (1+ i)))))
+
+(defun ccl-compile-if (cmd)
+  (if (and (/= (length cmd) 3) (/= (length cmd) 4))
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (let ((condition (nth 1 cmd))
+	(true-cmds (nth 2 cmd))
+	(false-cmds (nth 3 cmd))
+	ic0 ic1 ic2)
+    (if (listp condition)
+	;; cmd == (if (XXX OP YYY) ...)
+	(if (listp (car condition))
+	    ;; cmd == (if ((xxx op yyy) OP YYY) ...)
+	    (progn
+	      (ccl-compile-expression 'r7 (car condition))
+	      (setq condition (cons 'r7 (cdr condition)))
+	      (setq cmd (cons (car cmd)
+			      (cons condition
+				    (cdr (cdr cmd))))))))
+    (setq ic0 ccl-current-ic)
+    (ccl-embed-nop (if (listp condition) 3 1))
+    (ccl-compile-1 true-cmds)
+    (if (null false-cmds)
+	(setq ic1 ccl-current-ic)
+      (setq ic2 ccl-current-ic)
+      (ccl-embed-const 0)
+      (setq ic1 ccl-current-ic)
+      (ccl-compile-1 false-cmds)
+      (ccl-embed-code 'jump 0 ccl-current-ic ic2))
+    (if (symbolp condition)
+	(ccl-embed-code 'jump-cond condition ic1 ic0)
+      (let ((arg (nth 2 condition)))
+	(if (integer-or-char-p arg)
+	    (progn
+	      (ccl-embed-code 'jump-cond-c (car condition) ic1 ic0)
+	      (ccl-embed-const arg (1+ ic0)))
+	  (ccl-check-register arg cmd)
+	  (ccl-embed-code 'jump-cond-r (car condition) ic1 ic0)
+	  (ccl-embed-const (get arg 'ccl-register-number) (1+ ic0)))
+	(ccl-embed-const (get (nth 1 condition) 'ccl-arith-code) (+ ic0 2))))))
+
+(defun ccl-compile-branch (cmd)
+  (if (< (length cmd) 3)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (if (listp (nth 1 cmd))
+      (progn
+	(ccl-compile-expression 'r7 (nth 1 cmd))
+	(setq cmd (cons (car cmd)
+			(cons 'r7 (cdr (cdr cmd)))))))
+  (ccl-compile-branch-1 cmd))
+
+(defun ccl-compile-read-branch (cmd)
+  (ccl-compile-branch-1 cmd))
+
+(defun ccl-compile-branch-1 (cmd)
+  (if (< (length cmd) 3)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (let ((rrr (ccl-check-register (car (cdr cmd)) cmd))
+	(branches (cdr (cdr cmd)))
+	i ic0 ic1 ic2
+	branch-tails)
+    (ccl-embed-code (car cmd) rrr (- (length cmd) 2))
+    (setq ic0 ccl-current-ic)
+    (ccl-embed-nop (1- (length cmd)))
+    (setq i 0)
+    (while branches
+      (ccl-embed-const ccl-current-ic (+ ic0 i))
+      (ccl-compile-1 (car branches))
+      (setq branch-tails (cons ccl-current-ic branch-tails))
+      (ccl-embed-nop)
+      (setq i (1+ i))
+      (setq branches (cdr branches)))
+    ;; We don't need `jump' from the last branch.
+    (setq branch-tails (cdr branch-tails))
+    (setq ccl-current-ic (1- ccl-current-ic))
+    (while branch-tails
+      (ccl-embed-code 'jump 0 ccl-current-ic (car branch-tails))
+      (setq branch-tails (cdr branch-tails)))
+    ;; This is the case `rrr' is out of range.
+    (ccl-embed-const ccl-current-ic (+ ic0 i))
+    ))
+
+(defun ccl-compile-loop (cmd)
+  (if (< (length cmd) 2)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (let ((ccl-loop-head ccl-current-ic)
+	(ccl-breaks nil))
+    (setq cmd (cdr cmd))
+    (while cmd
+      (ccl-compile-1 (car cmd))
+      (setq cmd (cdr cmd)))
+    (while ccl-breaks
+      (ccl-embed-code 'jump 0 ccl-current-ic (car ccl-breaks))
+      (setq ccl-breaks (cdr ccl-breaks)))))
+
+(defun ccl-compile-break (cmd)
+  (if (/= (length cmd) 1)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (if (null ccl-loop-head)
+      (error "CCL: No outer loop: %s" cmd))
+  (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
+  (ccl-embed-nop))
+
+(defun ccl-compile-repeat (cmd)
+  (if (/= (length cmd) 1)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (if (null ccl-loop-head)
+      (error "CCL: No outer loop: %s" cmd))
+  (ccl-embed-code 'jump 0 ccl-loop-head))
+
+(defun ccl-compile-write-repeat (cmd)
+  (if (/= (length cmd) 2)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (if (null ccl-loop-head)
+      (error "CCL: No outer loop: %s" cmd))
+  (let ((arg (nth 1 cmd)))
+    (cond ((integer-or-char-p arg)
+	   (ccl-embed-code 'write-c-jump 0 ccl-loop-head)
+	   (ccl-embed-const arg))
+	  ((stringp arg)
+	   (ccl-embed-code 'write-s-jump 0 ccl-loop-head)
+	   (let ((i 0) (len (length arg)))
+	     (ccl-embed-const (length arg))
+	     (while (< i len)
+	       (ccl-embed-const (aref arg i))
+	       (setq i (1+ i)))))
+	  (t
+	   (ccl-check-register arg cmd)
+	   (ccl-embed-code 'write-jump arg ccl-loop-head)))))
+
+(defun ccl-compile-write-read-repeat (cmd)
+  (if (or (< (length cmd) 2) (> (length cmd) 3))
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (if (null ccl-loop-head)
+      (error "CCL: No outer loop: %s" cmd))
+  (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
+	(arg (nth 2 cmd)))
+    (cond ((null arg)
+	   (ccl-embed-code 'write-read-jump rrr ccl-loop-head))
+	  ((integer-or-char-p arg)
+	   (ccl-embed-code 'write-c-read-jump rrr ccl-loop-head)
+	   (ccl-embed-const arg))
+	  ((or (stringp arg) (vectorp arg))
+	   (ccl-embed-code (if (stringp arg)
+			       'write-s-read-jump
+			     'write-a-read-jump)
+			   rrr ccl-loop-head)
+	   (let ((i 0) (len (length arg)))
+	     (ccl-embed-const (length arg))
+	     (while (< i len)
+	       (ccl-embed-const (aref arg i))
+	       (setq i (1+ i)))))
+	  (t (error "CCL: Invalide argument %s: %s" arg cmd)))))
+			    
+(defun ccl-compile-read (cmd)
+  (let ((rrr (ccl-check-register (nth 1 cmd) cmd)))
+    (cond ((= (length cmd) 2)
+	   (ccl-embed-code 'read1 rrr 0))
+	  ((= (length cmd) 3)
+	   (ccl-embed-code 'read2 rrr (get (nth 2 cmd) 'ccl-register-number)))
+	  (t (error "CCL: Invalid number of arguments: %s" cmd)))))
+
+(defun ccl-compile-read-if (cmd)
+  (if (and (/= (length cmd) 3) (/= (length cmd) 4))
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (let* ((expr (nth 1 cmd))
+	 (rrr (ccl-check-register (car expr) cmd))
+	 (true-cmds (nth 2 cmd))
+	 (false-cmds (nth 3 cmd))
+	 ic0 ic1 ic2)
+    (setq ic0 ccl-current-ic)
+    (ccl-embed-nop 3)
+    (ccl-compile-1 true-cmds)
+    (if (null false-cmds)
+	(setq ic1 ccl-current-ic)
+      (setq ic2 ccl-current-ic)
+      (ccl-embed-const 0)
+      (setq ic1 ccl-current-ic)
+      (ccl-compile-1 false-cmds)
+      (ccl-embed-code 'jump 0 ccl-current-ic ic2))
+    (let ((arg (nth 2 expr)))
+      (ccl-embed-code (if (integer-or-char-p arg) 'read-jump-cond-c
+			'read-jump-cond-r)
+		      rrr ic1 ic0)
+      (ccl-embed-const (if (integer-or-char-p arg) arg
+			 (get arg 'ccl-register-number))
+		       (1+ ic0))
+      (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code) (+ ic0 2)))))
+
+(defun ccl-compile-write (cmd)
+  (if (and (/= (length cmd) 2) (/= (length cmd) 3))
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (let ((rrr (nth 1 cmd)))
+    (cond ((integer-or-char-p rrr)
+	   (ccl-embed-code 'write-c 0 0)
+	   (ccl-embed-const rrr))
+	  ((stringp rrr)
+	   (ccl-compile-write-string (list 'write rrr)))
+	  (t
+	   (ccl-check-register rrr cmd)
+	   (let ((arg (nth 2 cmd)))
+	     (if arg
+		 (cond ((symbolp arg)
+			(ccl-check-register arg cmd)
+			(ccl-embed-code 'write2 rrr
+					(get arg 'ccl-register-number)))
+		       ((vectorp arg)
+			(let ((i 0) (len (length arg)))
+			  (ccl-embed-code 'write-a rrr 0)
+			  (ccl-embed-const len)
+			  (while (< i len)
+			    (ccl-embed-const (aref arg i))
+			    (setq i (1+ i)))))
+		       (t (error "CCL: Invalid argument %s: %s" arg cmd)))
+	       (ccl-embed-code 'write1 rrr 0)))))))
+
+(defun ccl-compile-end (cmd)
+  (if (/= (length cmd) 1)
+      (error "CCL: Invalid number of arguments: %s" cmd))
+  (ccl-embed-code 'end 0 0))
+
+;;; CCL dump staffs
+(defvar ccl-program-vector-dump nil)
+
+;;;###autoload
+(defun ccl-dump (ccl-code)
+  "Disassemble compiled CCL-CODE."
+  (save-excursion
+    (set-buffer (get-buffer-create "*CCL-Dump*"))
+    (erase-buffer)
+    (setq ccl-program-vector-dump ccl-code)
+    (let ((len (length ccl-code)))
+      (insert "Main:\n")
+      (setq ccl-current-ic 1)
+      (if (> (aref ccl-code 0) 0)
+	  (progn
+	    (while (< ccl-current-ic (aref ccl-code 0))
+	      (ccl-dump-1))
+	    (insert "At EOF:\n")))
+      (while (< ccl-current-ic len)
+	(ccl-dump-1))
+      ))
+  (display-buffer (get-buffer "*CCL-Dump*")))
+
+(defun ccl-get-next-code ()
+  (prog1
+      (aref ccl-program-vector-dump ccl-current-ic)
+    (setq ccl-current-ic (1+ ccl-current-ic))))
+
+(defun ccl-dump-1 ()
+  (let* ((opcode (ccl-get-next-code))
+	 (code (logand opcode 31))
+	 (cmd (aref ccl-machine-code-table code))
+	 (rrr (logand (ash opcode -5) 7))
+	 (cc (ash opcode -8)))
+    (insert (format "%4d: " (1- ccl-current-ic)))
+    (funcall (get cmd 'ccl-dump-function) rrr cc))) 
+
+(defun ccl-dump-set-cs (rrr cc)
+  (insert (format "r%d = %s\n" rrr cc)))
+
+(defun ccl-dump-set-cl (rrr cc)
+  (setq cc (ccl-get-next-code))
+  (insert (format "r%d = %s\n" rrr cc)))
+
+(defun ccl-dump-set-r (rrr cc)
+  (insert (format "r%d = r%d\n" rrr cc)))
+
+(defun ccl-dump-set-a (rrr cc)
+  (let ((range (ccl-get-next-code)) (i 0))
+    (insert (format "r%d = array[r%d] of length %d\n\t"
+		    rrr cc range))
+    (let ((i 0))
+      (while (< i range)
+	(insert (format "%d " (ccl-get-next-code)))
+	(setq i (1+ i))))
+    (insert "\n")))
+
+(defun ccl-dump-jump (rrr cc)
+  (insert (format "jump to %d\n" cc)))
+
+(defun ccl-dump-jump-cond (rrr cc)
+  (insert (format "if !(r%d), jump to %d\n" rrr cc)))
+
+(defun ccl-dump-write-jump (rrr cc)
+  (insert (format "write r%d, jump to %d\n" rrr cc)))
+
+(defun ccl-dump-write-read-jump (rrr cc)
+  (insert (format "write r%d, read r%d, jump to %d\n" rrr rrr cc)))
+
+(defun ccl-dump-write-c-jump (rrr cc)
+  (let ((const (ccl-get-next-code)))
+    (insert (format "write %s, jump to %d\n" const cc))))
+
+(defun ccl-dump-write-c-read-jump (rrr cc)
+  (let ((const (ccl-get-next-code)))
+    (insert (format "write %s, read r%d, jump to %d\n" const rrr cc))))
+
+(defun ccl-dump-write-s-jump (rrr cc)
+  (let ((len (ccl-get-next-code)) (i 0))
+    (insert "write \"")
+    (while (< i len)
+      (insert (format "%c" (ccl-get-next-code)))
+      (setq i (1+ i)))
+    (insert (format "\", jump to %d\n" cc))))
+
+(defun ccl-dump-write-s-read-jump (rrr cc)
+  (let ((len (ccl-get-next-code)) (i 0))
+    (insert "write \"")
+    (while (< i len)
+      (insert (format "%c" (ccl-get-next-code)))
+      (setq i (1+ i)))
+    (insert (format "\", read r%d, jump to %d\n" rrr cc))))
+
+(defun ccl-dump-write-a-read-jump (rrr cc)
+  (let ((len (ccl-get-next-code)) (i 0))
+    (insert (format "write array[r%d] of length %d, read r%d, jump to %d\n\t"
+		    rrr len rrr cc))
+    (while (< i len)
+      (insert (format "%d " (ccl-get-next-code)))
+      (setq i (1+ i)))
+    (insert "\n")))
+
+(defun ccl-dump-branch (rrr cc)
+  (let ((i 0))
+    (insert (format "jump to array[r%d] of length %d)\n\t" rrr cc))
+    (while (<= i cc)
+      (insert (format "%d " (ccl-get-next-code)))
+      (setq i (1+ i)))
+    (insert "\n")))
+
+(defun ccl-dump-read1 (rrr cc)
+  (insert (format "read r%d\n" rrr)))
+
+(defun ccl-dump-read2 (rrr cc)
+  (insert (format "read r%d and r%d\n" rrr cc)))
+
+(defun ccl-dump-read-branch (rrr cc)
+  (insert (format "read r%d, " rrr))
+  (ccl-dump-branch rrr cc))
+
+(defun ccl-dump-write1 (rrr cc)
+  (insert (format "write r%d\n" rrr)))
+
+(defun ccl-dump-write2 (rrr cc)
+  (insert (format "write r%d and r%d\n" rrr cc)))
+
+(defun ccl-dump-write-c (rrr cc)
+  (insert (format "write %s\n" (ccl-get-next-code))))
+
+(defun ccl-dump-write-s (rrr cc)
+  (let ((len (ccl-get-next-code)) (i 0))
+    (insert "write \"")
+    (while (< i len)
+      (insert (format "%c" (ccl-get-next-code)))
+      (setq i (1+ i)))
+    (insert "\"\n")))
+
+(defun ccl-dump-write-a (rrr cc)
+  (let ((len (ccl-get-next-code)) (i 0))
+    (insert (format "write array[r%d] of length %d\n\t" rrr len))
+    (while (< i 0)
+      (insert "%d " (ccl-get-next-code))
+      (setq i (1+ i)))
+    (insert "\n")))
+
+(defun ccl-dump-end (rrr cc)
+  (insert "end\n"))
+
+(defun ccl-dump-set-self-cs (rrr cc)
+  (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "r%d %s= %s\n" rrr arith cc))))
+
+(defun ccl-dump-set-self-cl (rrr cc)
+  (setq cc (ccl-get-next-code))
+  (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "r%d %s= %s\n" rrr arith cc))))
+
+(defun ccl-dump-set-self-r (rrr cc)
+  (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "r%d %s= r%d\n" rrr arith cc))))
+
+(defun ccl-dump-set-expr-cl (rrr cc)
+  (let ((const (ccl-get-next-code))
+	(arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "r%d = r%d %s %s\n" rrr cc arith const))))
+
+(defun ccl-dump-set-expr-r (rrr cc)
+  (let ((reg (ccl-get-next-code))
+	(arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "r%d = r%d %s r%d\n" rrr cc arith reg))))
+
+(defun ccl-dump-jump-cond-c (rrr cc)
+  (let ((const (ccl-get-next-code))
+	(arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "if !(r%d %s %s), jump to %d\n" rrr arith const cc))))
+
+(defun ccl-dump-jump-cond-r (rrr cc)
+  (let ((reg (ccl-get-next-code))
+	(arith (aref ccl-arith-table (ccl-get-next-code))))
+    (insert (format "if !(r%d %s r%d), jump to %d\n" rrr arith reg cc))))
+
+(defun ccl-dump-read-jump-cond-c (rrr cc)
+  (insert (format "read r%d, " rrr))
+  (ccl-dump-jump-cond-c rrr cc))
+
+(defun ccl-dump-read-jump-cond-r (rrr cc)
+  (insert (format "read r%d, " rrr))
+  (ccl-dump-jump-cond-r rrr cc))
+
+;; CCL emulation staffs 
+
+;; Not yet implemented.
+
+;; For byte-compiler
+
+;;;###autoload
+(defmacro define-ccl-program (name ccl-program &optional doc)
+  "Does (defconst NAME (ccl-compile (eval CCL-PROGRAM)) DOC).
+Byte-compiler expand this macro while compiling."
+  (` (defconst (, name) (, (ccl-compile (eval ccl-program))) (, doc))))
+
+(put 'define-ccl-program 'byte-hunk-handler 'macroexpand)
+
+(provide 'ccl)