(defgroup ccl nil
"CCL (Code Conversion Language) compiler."
:prefix "ccl-"
:group 'i18n)
(defconst ccl-command-table
[if branch loop break repeat write-repeat write-read-repeat
read read-if read-branch write call end
read-multibyte-character write-multibyte-character
translate-character
iterate-multiple-map map-multiple map-single]
"Vector of CCL commands (symbols).")
(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
ex-cmd
]
"Vector of CCL compiled codes (symbols).")
(defconst ccl-extended-code-table
[read-multibyte-character
write-multibyte-character
translate-character
translate-character-const-tbl
nil nil nil nil nil nil nil nil nil nil nil nil iterate-multiple-map
map-multiple
map-single
]
"Vector of CCL extended compiled codes (symbols).")
(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))))
(let (code (i 0) (len (length ccl-extended-code-table)))
(while (< i len)
(setq code (aref ccl-extended-code-table i))
(if code
(progn
(put code 'ccl-ex-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))
(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).")
(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).")
(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).")
(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'.")
(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))))
(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)))))
(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)))))
(defun ccl-embed-code (op reg data &optional reg2)
(if (and (> data 0) (get op 'jump-flag))
(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))))
(defun ccl-embed-extended-command (ex-op reg reg2 reg3)
(let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
(if (symbolp reg3)
(get reg3 'ccl-register-number)
0))))
(ccl-embed-code 'ex-cmd reg data reg2)))
(defun ccl-increment-ic (inc)
(setq ccl-current-ic (+ ccl-current-ic inc)))
(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)
(defun ccl-compile (ccl-program)
"Return a compiled 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)
(ccl-embed-data (car ccl-program))
(ccl-increment-ic 1)
(ccl-compile-1 (car (cdr ccl-program)))
(ccl-embed-data ccl-current-ic 1)
(if (nth 2 ccl-program)
(ccl-compile-1 (nth 2 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-syntax-error (cmd)
(error "CCL: Syntax error: %s" cmd))
(defun ccl-check-register (arg cmd)
(if (get arg 'ccl-register-number)
arg
(error "CCL: Invalid register %s in %s." arg cmd)))
(defun ccl-check-compile-function (arg cmd)
(or (get arg 'ccl-compile-function)
(error "CCL: Invalid command: %s" cmd)))
(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))))
(setq ccl-block (list ccl-block)))
(while ccl-block
(setq cmd (car ccl-block))
(setq unconditional-jump
(cond ((integerp cmd)
(ccl-compile-set (list 'r0 '= cmd)))
((stringp cmd)
(ccl-compile-write-string cmd))
((listp cmd)
(cond ((eq (nth 1 cmd) '=)
(ccl-compile-set cmd))
((and (symbolp (nth 1 cmd))
(get (nth 1 cmd) 'ccl-self-arith-code))
(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))
(defun ccl-compile-set (cmd)
(let ((rrr (ccl-check-register (car cmd) cmd))
(right (nth 2 cmd)))
(cond ((listp right)
(ccl-compile-expression rrr right))
((integerp right)
(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
(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)
(defun ccl-compile-self-set (cmd)
(let ((rrr (ccl-check-register (car cmd) cmd))
(right (nth 2 cmd)))
(if (listp right)
(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)))
nil)
(defun ccl-compile-expression (rrr expr)
(let ((left (car expr))
(op (get (nth 1 expr) 'ccl-arith-code))
(right (nth 2 expr)))
(if (listp left)
(progn
(ccl-compile-expression 'r7 left)
(setq left 'r7)))
(if (eq rrr left)
(if (integerp right)
(progn
(ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
(ccl-embed-data right))
(ccl-check-register right expr)
(ccl-embed-code 'set-assign-expr-register rrr (ash op 3) right))
(if (integerp right)
(progn
(ccl-embed-code 'set-expr-const rrr (ash op 3) left)
(ccl-embed-data right))
(ccl-check-register right expr)
(ccl-embed-code 'set-expr-register
rrr
(logior (ash op 3) (get right 'ccl-register-number))
left)))))
(defun ccl-compile-write-string (str)
(setq str (string-as-unibyte str))
(let ((len (length str)))
(ccl-embed-code 'write-const-string 1 len)
(ccl-embed-string len str))
nil)
(defun ccl-compile-if (cmd &optional read-flag)
(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))
jump-cond-address
false-ic)
(if (and (listp condition)
(listp (car condition)))
(progn
(ccl-compile-expression 'r7 (car condition))
(setq condition (cons 'r7 (cdr condition)))
(setq cmd (cons (car cmd)
(cons condition (cdr (cdr cmd)))))))
(setq jump-cond-address ccl-current-ic)
(if (symbolp condition)
(progn
(ccl-check-register condition cmd)
(ccl-embed-code 'jump-cond condition 0))
(let ((rrr (car condition))
(op (get (nth 1 condition) 'ccl-arith-code))
(arg (nth 2 condition)))
(ccl-check-register rrr cmd)
(if (integerp arg)
(progn
(ccl-embed-code (if read-flag 'read-jump-cond-expr-const
'jump-cond-expr-const)
rrr 0)
(ccl-embed-data op)
(ccl-embed-data arg))
(ccl-check-register arg cmd)
(ccl-embed-code (if read-flag 'read-jump-cond-expr-register
'jump-cond-expr-register)
rrr 0)
(ccl-embed-data op)
(ccl-embed-data (get arg 'ccl-register-number)))))
(let ((unconditional-jump (ccl-compile-1 true-cmds)))
(if (null false-cmds)
(progn
(ccl-embed-current-address jump-cond-address)
(setq unconditional-jump nil))
(let (end-true-part-address)
(if (not unconditional-jump)
(progn
(setq end-true-part-address ccl-current-ic)
(ccl-embed-code 'jump 0 0)))
(ccl-embed-current-address jump-cond-address)
(setq unconditional-jump
(and (ccl-compile-1 false-cmds) unconditional-jump))
(if end-true-part-address
(ccl-embed-current-address end-true-part-address))))
unconditional-jump)))
(defun ccl-compile-branch (cmd)
(if (< (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(ccl-compile-branch-blocks 'branch
(ccl-compile-branch-expression (nth 1 cmd) cmd)
(cdr (cdr cmd))))
(defun ccl-compile-read-branch (cmd)
(if (< (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(ccl-compile-branch-blocks 'read-branch
(ccl-compile-branch-expression (nth 1 cmd) cmd)
(cdr (cdr cmd))))
(defun ccl-compile-branch-expression (expr cmd)
(if (listp expr)
(progn
(ccl-compile-expression 'r7 expr)
'r7)
(ccl-check-register expr cmd)))
(defun ccl-compile-branch-blocks (code rrr blocks)
(let ((branches (length blocks))
branch-idx
jump-table-head-address
empty-block-indexes
block-tail-addresses
block-unconditional-jump)
(ccl-embed-code code rrr branches)
(setq jump-table-head-address ccl-current-ic)
(ccl-increment-ic (1+ branches))
(setq empty-block-indexes (list branches))
(setq branch-idx 0)
(while blocks
(if (null (car blocks))
(setq empty-block-indexes (cons branch-idx empty-block-indexes)
block-unconditional-jump t)
(ccl-embed-data (- ccl-current-ic jump-table-head-address)
(+ jump-table-head-address branch-idx))
(setq block-unconditional-jump (ccl-compile-1 (car blocks)))
(if (not block-unconditional-jump)
(progn
(setq block-tail-addresses
(cons ccl-current-ic block-tail-addresses))
(ccl-embed-code 'jump 0 0))))
(setq branch-idx (1+ branch-idx))
(setq blocks (cdr blocks)))
(if (not block-unconditional-jump)
(setq block-tail-addresses (cdr block-tail-addresses)
ccl-current-ic (1- ccl-current-ic)))
(while block-tail-addresses
(ccl-embed-current-address (car block-tail-addresses))
(setq block-tail-addresses (cdr block-tail-addresses)))
(while empty-block-indexes
(ccl-embed-data (- ccl-current-ic jump-table-head-address)
(+ jump-table-head-address (car empty-block-indexes)))
(setq empty-block-indexes (cdr empty-block-indexes))))
nil)
(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)
unconditional-jump)
(setq cmd (cdr cmd))
(if cmd
(progn
(setq unconditional-jump t)
(while cmd
(setq unconditional-jump
(and (ccl-compile-1 (car cmd)) unconditional-jump))
(setq cmd (cdr cmd)))
(if (not ccl-breaks)
unconditional-jump
(while ccl-breaks
(ccl-embed-current-address (car ccl-breaks))
(setq ccl-breaks (cdr ccl-breaks))))
nil))))
(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-code 'jump 0 0)
t)
(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)
t)
(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 ((integerp arg)
(ccl-embed-code 'write-const-jump 0 ccl-loop-head)
(ccl-embed-data arg))
((stringp arg)
(setq arg (string-as-unibyte arg))
(let ((len (length arg))
(i 0))
(ccl-embed-code 'write-string-jump 0 ccl-loop-head)
(ccl-embed-data len)
(ccl-embed-string len arg)))
(t
(ccl-check-register arg cmd)
(ccl-embed-code 'write-register-jump arg ccl-loop-head))))
t)
(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-register-read-jump rrr ccl-loop-head))
((integerp arg)
(ccl-embed-code 'write-const-read-jump rrr arg ccl-loop-head))
((vectorp arg)
(let ((len (length arg))
(i 0))
(ccl-embed-code 'write-array-read-jump rrr ccl-loop-head)
(ccl-embed-data len)
(while (< i len)
(ccl-embed-data (aref arg i))
(setq i (1+ i)))))
(t
(error "CCL: Invalid argument %s: %s" arg cmd)))
(ccl-embed-code 'read-jump rrr ccl-loop-head))
t)
(defun ccl-compile-read (cmd)
(if (< (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(let* ((args (cdr cmd))
(i (1- (length args))))
(while args
(let ((rrr (ccl-check-register (car args) cmd)))
(ccl-embed-code 'read-register rrr i)
(setq args (cdr args) i (1- i)))))
nil)
(defun ccl-compile-read-if (cmd)
(ccl-compile-if cmd 'read))
(defun ccl-compile-write (cmd)
(if (< (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((rrr (nth 1 cmd)))
(cond ((integerp rrr)
(ccl-embed-code 'write-const-string 0 rrr))
((stringp rrr)
(ccl-compile-write-string rrr))
((and (symbolp rrr) (vectorp (nth 2 cmd)))
(ccl-check-register rrr cmd)
(let* ((arg (nth 2 cmd))
(len (length arg))
(i 0))
(ccl-embed-code 'write-array rrr len)
(while (< i len)
(if (not (integerp (aref arg i)))
(error "CCL: Invalid argument %s: %s" arg cmd))
(ccl-embed-data (aref arg i))
(setq i (1+ i)))))
((symbolp rrr)
(let* ((args (cdr cmd))
(i (1- (length args))))
(while args
(setq rrr (ccl-check-register (car args) cmd))
(ccl-embed-code 'write-register rrr i)
(setq args (cdr args) i (1- i)))))
((listp rrr)
(let ((left (car rrr))
(op (get (nth 1 rrr) 'ccl-arith-code))
(right (nth 2 rrr)))
(if (listp left)
(progn
(ccl-compile-expression 'r7 left)
(setq left 'r7)))
(if (integerp right)
(progn
(ccl-embed-code 'write-expr-const 0 (ash op 3) left)
(ccl-embed-data right))
(ccl-check-register right rrr)
(ccl-embed-code 'write-expr-register 0
(logior (ash op 3)
(get right 'ccl-register-number))))))
(t
(error "CCL: Invalid argument: %s" cmd))))
nil)
(defun ccl-compile-call (cmd)
(if (/= (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(if (not (symbolp (nth 1 cmd)))
(error "CCL: Subroutine should be a symbol: %s" cmd))
(let* ((name (nth 1 cmd))
(idx (get name 'ccl-program-idx)))
(if (not idx)
(error "CCL: Unknown subroutine name: %s" name))
(ccl-embed-code 'call 0 idx))
nil)
(defun ccl-compile-end (cmd)
(if (/= (length cmd) 1)
(error "CCL: Invalid number of arguments: %s" cmd))
(ccl-embed-code 'end 0 0)
t)
(defun ccl-compile-read-multibyte-character (cmd)
(if (/= (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(rrr (nth 2 cmd)))
(ccl-check-register rrr cmd)
(ccl-check-register RRR cmd)
(ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
nil)
(defun ccl-compile-write-multibyte-character (cmd)
(if (/= (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(rrr (nth 2 cmd)))
(ccl-check-register rrr cmd)
(ccl-check-register RRR cmd)
(ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
nil)
(defun ccl-compile-translate-character (cmd)
(if (/= (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((Rrr (nth 1 cmd))
(RRR (nth 2 cmd))
(rrr (nth 3 cmd)))
(ccl-check-register rrr cmd)
(ccl-check-register RRR cmd)
(cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
(if (not (get Rrr 'translation-table))
(error "CCL: Invalid translation table %s in %s" Rrr cmd))
(ccl-embed-extended-command 'translate-character-const-tbl
rrr RRR 0)
(ccl-embed-data Rrr))
(t
(ccl-check-register Rrr cmd)
(ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
nil)
(defun ccl-compile-iterate-multiple-map (cmd)
(ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
nil)
(defun ccl-compile-map-multiple (cmd)
(if (/= (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((func '(lambda (arg mp)
(let ((len 0) result add)
(while arg
(if (consp (car arg))
(setq add (funcall func (car arg) t)
result (append result add)
add (+ (-(car add)) 1))
(setq result
(append result
(list (car arg)))
add 1))
(setq arg (cdr arg)
len (+ len add)))
(if mp
(cons (- len) result)
result))))
arg)
(setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
(funcall func (nth 3 cmd) nil)))
(ccl-compile-multiple-map-function 'map-multiple arg))
nil)
(defun ccl-compile-map-single (cmd)
(if (/= (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(rrr (nth 2 cmd))
(map (nth 3 cmd))
id)
(ccl-check-register rrr cmd)
(ccl-check-register RRR cmd)
(ccl-embed-extended-command 'map-single rrr RRR 0)
(cond ((symbolp map)
(if (get map 'code-conversion-map)
(ccl-embed-data map)
(error "CCL: Invalid map: %s" map)))
(t
(error "CCL: Invalid type of arguments: %s" cmd))))
nil)
(defun ccl-compile-multiple-map-function (command cmd)
(if (< (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(rrr (nth 2 cmd))
(args (nthcdr 3 cmd))
map)
(ccl-check-register rrr cmd)
(ccl-check-register RRR cmd)
(ccl-embed-extended-command command rrr RRR 0)
(ccl-embed-data (length args))
(while args
(setq map (car args))
(cond ((symbolp map)
(if (get map 'code-conversion-map)
(ccl-embed-data map)
(error "CCL: Invalid map: %s" map)))
((numberp map)
(ccl-embed-data map))
(t
(error "CCL: Invalid type of arguments: %s" cmd)))
(setq args (cdr args)))))
(defvar ccl-code)
(defun ccl-dump (ccl-code)
"Disassemble compiled CCL-CODE."
(let ((len (length ccl-code))
(buffer-mag (aref ccl-code 0)))
(cond ((= buffer-mag 0)
(insert "Don't output anything.\n"))
((= buffer-mag 1)
(insert "Out-buffer must be as large as in-buffer.\n"))
(t
(insert
(format "Out-buffer must be %d times bigger than in-buffer.\n"
buffer-mag))))
(insert "Main-body:\n")
(setq ccl-current-ic 2)
(if (> (aref ccl-code 1) 0)
(progn
(while (< ccl-current-ic (aref ccl-code 1))
(ccl-dump-1))
(insert "At EOF:\n")))
(while (< ccl-current-ic len)
(ccl-dump-1))
))
(defun ccl-get-next-code ()
(prog1
(aref ccl-code ccl-current-ic)
(setq ccl-current-ic (1+ ccl-current-ic))))
(defun ccl-dump-1 ()
(let* ((code (ccl-get-next-code))
(cmd (aref ccl-code-table (logand code 31)))
(rrr (ash (logand code 255) -5))
(cc (ash code -8)))
(insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
(funcall (get cmd 'ccl-dump-function) rrr cc)))
(defun ccl-dump-set-register (rrr cc)
(insert (format "r%d = r%d\n" rrr cc)))
(defun ccl-dump-set-short-const (rrr cc)
(insert (format "r%d = %d\n" rrr cc)))
(defun ccl-dump-set-const (rrr ignore)
(insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
(defun ccl-dump-set-array (rrr cc)
(let ((rrr2 (logand cc 7))
(len (ash cc -3))
(i 0))
(insert (format "r%d = array[r%d] of length %d\n\t"
rrr rrr2 len))
(while (< i len)
(insert (format "%d " (ccl-get-next-code)))
(setq i (1+ i)))
(insert "\n")))
(defun ccl-dump-jump (ignore cc &optional address)
(insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
(if (>= cc 0)
(insert "+"))
(insert (format "%d)\n" (1+ cc))))
(defun ccl-dump-jump-cond (rrr cc)
(insert (format "if (r%d == 0), " rrr))
(ccl-dump-jump nil cc))
(defun ccl-dump-write-register-jump (rrr cc)
(insert (format "write r%d, " rrr))
(ccl-dump-jump nil cc))
(defun ccl-dump-write-register-read-jump (rrr cc)
(insert (format "write r%d, read r%d, " rrr rrr))
(ccl-dump-jump nil cc)
(ccl-get-next-code) )
(defun ccl-extract-arith-op (cc)
(aref ccl-arith-table (ash cc -6)))
(defun ccl-dump-write-expr-const (ignore cc)
(insert (format "write (r%d %s %d)\n"
(logand cc 7)
(ccl-extract-arith-op cc)
(ccl-get-next-code))))
(defun ccl-dump-write-expr-register (ignore cc)
(insert (format "write (r%d %s r%d)\n"
(logand cc 7)
(ccl-extract-arith-op cc)
(logand (ash cc -3) 7))))
(defun ccl-dump-insert-char (cc)
(cond ((= cc ?\t) (insert " \"^I\""))
((= cc ?\n) (insert " \"^J\""))
(t (insert (format " \"%c\"" cc)))))
(defun ccl-dump-write-const-jump (ignore cc)
(let ((address ccl-current-ic))
(insert "write char")
(ccl-dump-insert-char (ccl-get-next-code))
(insert ", ")
(ccl-dump-jump nil cc address)))
(defun ccl-dump-write-const-read-jump (rrr cc)
(let ((address ccl-current-ic))
(insert "write char")
(ccl-dump-insert-char (ccl-get-next-code))
(insert (format ", read r%d, " rrr))
(ccl-dump-jump cc address)
(ccl-get-next-code) ))
(defun ccl-dump-write-string-jump (ignore cc)
(let ((address ccl-current-ic)
(len (ccl-get-next-code))
(i 0))
(insert "write \"")
(while (< i len)
(let ((code (ccl-get-next-code)))
(insert (ash code -16))
(if (< (1+ i) len) (insert (logand (ash code -8) 255)))
(if (< (+ i 2) len) (insert (logand code 255))))
(setq i (+ i 3)))
(insert "\", ")
(ccl-dump-jump nil cc address)))
(defun ccl-dump-write-array-read-jump (rrr cc)
(let ((address ccl-current-ic)
(len (ccl-get-next-code))
(i 0))
(insert (format "write array[r%d] of length %d,\n\t" rrr len))
(while (< i len)
(ccl-dump-insert-char (ccl-get-next-code))
(setq i (1+ i)))
(insert (format "\n\tthen read r%d, " rrr))
(ccl-dump-jump nil cc address)
(ccl-get-next-code) ))
(defun ccl-dump-read-jump (rrr cc)
(insert (format "read r%d, " rrr))
(ccl-dump-jump nil cc))
(defun ccl-dump-branch (rrr len)
(let ((jump-table-head ccl-current-ic)
(i 0))
(insert (format "jump to array[r%d] of length %d\n\t" rrr len))
(while (<= i len)
(insert (format "%d " (+ jump-table-head (ccl-get-next-code))))
(setq i (1+ i)))
(insert "\n")))
(defun ccl-dump-read-register (rrr cc)
(insert (format "read r%d (%d remaining)\n" rrr cc)))
(defun ccl-dump-read-branch (rrr len)
(insert (format "read r%d, " rrr))
(ccl-dump-branch rrr len))
(defun ccl-dump-write-register (rrr cc)
(insert (format "write r%d (%d remaining)\n" rrr cc)))
(defun ccl-dump-call (ignore cc)
(insert (format "call subroutine #%d\n" cc)))
(defun ccl-dump-write-const-string (rrr cc)
(if (= rrr 0)
(progn
(insert "write char")
(ccl-dump-insert-char cc)
(newline))
(let ((len cc)
(i 0))
(insert "write \"")
(while (< i len)
(let ((code (ccl-get-next-code)))
(insert (format "%c" (lsh code -16)))
(if (< (1+ i) len)
(insert (format "%c" (logand (lsh code -8) 255))))
(if (< (+ i 2) len)
(insert (format "%c" (logand code 255))))
(setq i (+ i 3))))
(insert "\"\n"))))
(defun ccl-dump-write-array (rrr cc)
(let ((i 0))
(insert (format "write array[r%d] of length %d\n\t" rrr cc))
(while (< i cc)
(ccl-dump-insert-char (ccl-get-next-code))
(setq i (1+ i)))
(insert "\n")))
(defun ccl-dump-end (&rest ignore)
(insert "end\n"))
(defun ccl-dump-set-assign-expr-const (rrr cc)
(insert (format "r%d %s= %d\n"
rrr
(ccl-extract-arith-op cc)
(ccl-get-next-code))))
(defun ccl-dump-set-assign-expr-register (rrr cc)
(insert (format "r%d %s= r%d\n"
rrr
(ccl-extract-arith-op cc)
(logand cc 7))))
(defun ccl-dump-set-expr-const (rrr cc)
(insert (format "r%d = r%d %s %d\n"
rrr
(logand cc 7)
(ccl-extract-arith-op cc)
(ccl-get-next-code))))
(defun ccl-dump-set-expr-register (rrr cc)
(insert (format "r%d = r%d %s r%d\n"
rrr
(logand cc 7)
(ccl-extract-arith-op cc)
(logand (ash cc -3) 7))))
(defun ccl-dump-jump-cond-expr-const (rrr cc)
(let ((address ccl-current-ic))
(insert (format "if !(r%d %s %d), "
rrr
(aref ccl-arith-table (ccl-get-next-code))
(ccl-get-next-code)))
(ccl-dump-jump nil cc address)))
(defun ccl-dump-jump-cond-expr-register (rrr cc)
(let ((address ccl-current-ic))
(insert (format "if !(r%d %s r%d), "
rrr
(aref ccl-arith-table (ccl-get-next-code))
(ccl-get-next-code)))
(ccl-dump-jump nil cc address)))
(defun ccl-dump-read-jump-cond-expr-const (rrr cc)
(insert (format "read r%d, " rrr))
(ccl-dump-jump-cond-expr-const rrr cc))
(defun ccl-dump-read-jump-cond-expr-register (rrr cc)
(insert (format "read r%d, " rrr))
(ccl-dump-jump-cond-expr-register rrr cc))
(defun ccl-dump-binary (ccl-code)
(let ((len (length ccl-code))
(i 2))
(while (< i len)
(let ((code (aref ccl-code i))
(j 27))
(while (>= j 0)
(insert (if (= (logand code (ash 1 j)) 0) ?0 ?1))
(setq j (1- j)))
(setq code (logand code 31))
(if (< code (length ccl-code-table))
(insert (format ":%s" (aref ccl-code-table code))))
(insert "\n"))
(setq i (1+ i)))))
(defun ccl-dump-ex-cmd (rrr cc)
(let* ((RRR (logand cc ?\x7))
(Rrr (logand (ash cc -3) ?\x7))
(ex-op (aref ccl-extended-code-table (logand (ash cc -6) ?\x3fff))))
(insert (format "<%s> " ex-op))
(funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
(defun ccl-dump-read-multibyte-character (rrr RRR Rrr)
(insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
(defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
(insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
(defun ccl-dump-translate-character (rrr RRR Rrr)
(insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
(defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
(let ((tbl (ccl-get-next-code)))
(insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
(defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
(let ((notbl (ccl-get-next-code))
(i 0) id)
(insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
(insert (format "\tnumber of maps is %d .\n\t [" notbl))
(while (< i notbl)
(setq id (ccl-get-next-code))
(insert (format "%S" id))
(setq i (1+ i)))
(insert "]\n")))
(defun ccl-dump-map-multiple (rrr RRR Rrr)
(let ((notbl (ccl-get-next-code))
(i 0) id)
(insert (format "map-multiple r%d r%d\n" RRR rrr))
(insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
(while (< i notbl)
(setq id (ccl-get-next-code))
(if (= id -1)
(insert "]\n\t [")
(insert (format "%S " id)))
(setq i (1+ i)))
(insert "]\n")))
(defun ccl-dump-map-single (rrr RRR Rrr)
(let ((id (ccl-get-next-code)))
(insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
(defmacro declare-ccl-program (name &optional vector)
"Declare NAME as a name of CCL program.
To compile a CCL program which calls another CCL program not yet
defined, it must be declared as a CCL program in advance.
Optional arg VECTOR is a compiled CCL code of the CCL program."
`(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
(defmacro define-ccl-program (name ccl-program &optional doc)
"Set NAME the compiled code of CCL-PROGRAM.
CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'.
The compiled code is a vector of integers."
`(let ((prog ,(ccl-compile (eval ccl-program))))
(defconst ,name prog ,doc)
(put ',name 'ccl-program-idx (register-ccl-program ',name prog))
nil))
(defmacro check-ccl-program (ccl-program &optional name)
"Check validity of CCL-PROGRAM.
If CCL-PROGRAM is a symbol denoting a valid CCL program, return
CCL-PROGRAM, else return nil.
If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
register CCL-PROGRAM by name NAME, and return NAME."
`(let ((result ,ccl-program))
(cond ((symbolp ,ccl-program)
(or (numberp (get ,ccl-program 'ccl-program-idx))
(setq result nil)))
((vectorp ,ccl-program)
(setq result ,name)
(register-ccl-program result ,ccl-program))
(t
(setq result nil)))
result))
(defun ccl-execute-with-args (ccl-prog &rest args)
"Execute CCL-PROGRAM with registers initialized by the remaining args.
The return value is a vector of resulting CCL registers."
(let ((reg (make-vector 8 0))
(i 0))
(while (and args (< i 8))
(if (not (integerp (car args)))
(error "Arguments should be integer"))
(aset reg i (car args))
(setq args (cdr args) i (1+ i)))
(ccl-execute ccl-prog reg)
reg))
(provide 'ccl)