1 ;;; ccl.el --- CCL (Code Conversion Language) compiler
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
4 ;; Licensed to the Free Software Foundation.
6 ;; Keywords: CCL, mule, multilingual, character set, coding-system
8 ;; This file is part of X Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
25 ;; Synched up with: FSF 20.2
29 ;; CCL (Code Conversion Language) is a simple programming language to
30 ;; be used for various kind of code conversion. CCL program is
31 ;; compiled to CCL code (vector of integers) and executed by CCL
32 ;; interpreter of Emacs.
34 ;; CCL is used for code conversion at process I/O and file I/O for
35 ;; non-standard coding-system. In addition, it is used for
36 ;; calculating a code point of X's font from a character code.
37 ;; However, since CCL is designed as a powerful programming language,
38 ;; it can be used for more generic calculation. For instance,
39 ;; combination of three or more arithmetic operations can be
40 ;; calculated faster than Emacs Lisp.
42 ;; Here's the syntax of CCL program in BNF notation.
45 ;; (BUFFER_MAGNIFICATION
49 ;; BUFFER_MAGNIFICATION := integer
50 ;; CCL_MAIN_BLOCK := CCL_BLOCK
51 ;; CCL_EOF_BLOCK := CCL_BLOCK
54 ;; STATEMENT | (STATEMENT [STATEMENT ...])
56 ;; SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
60 ;; | (REG ASSIGNMENT_OPERATOR EXPRESSION)
63 ;; EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
65 ;; IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK)
66 ;; BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...])
67 ;; LOOP := (loop STATEMENT [STATEMENT ...])
71 ;; | (write-repeat [REG | integer | string])
72 ;; | (write-read-repeat REG [integer | ARRAY])
75 ;; | (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK)
76 ;; | (read-branch REG CCL_BLOCK [CCL_BLOCK ...])
77 ;; | (read-multibyte-character REG {charset} REG {code-point})
80 ;; | (write EXPRESSION)
81 ;; | (write integer) | (write string) | (write REG ARRAY)
83 ;; | (write-multibyte-character REG(charset) REG(codepoint))
84 ;; CALL := (call ccl-program-name)
87 ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
88 ;; ARG := REG | integer
90 ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
91 ;; | < | > | == | <= | >= | != | de-sjis | en-sjis
92 ;; ASSIGNMENT_OPERATOR :=
93 ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
94 ;; ARRAY := '[' integer ... ']'
99 "CCL (Code Conversion Language) compiler."
103 (defconst ccl-command-table
104 [if branch loop break repeat write-repeat write-read-repeat
105 read read-if read-branch write call end
106 read-multibyte-character write-multibyte-character]
107 "Vector of CCL commands (symbols).")
109 ;; Put a property to each symbol of CCL commands for the compiler.
110 (let (op (i 0) (len (length ccl-command-table)))
112 (setq op (aref ccl-command-table i))
113 (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
116 (defconst ccl-code-table
124 write-register-read-jump
126 write-const-read-jump
128 write-array-read-jump
140 set-assign-expr-const
141 set-assign-expr-register
145 jump-cond-expr-register
146 read-jump-cond-expr-const
147 read-jump-cond-expr-register
150 "Vector of CCL compiled codes (symbols).")
152 (defconst ccl-extended-code-table
153 [read-multibyte-character
154 write-multibyte-character
156 translate-character-const-tbl
157 nil nil nil nil nil nil nil nil nil nil nil nil ; 0x04-0x0f
162 "Vector of CCL extended compiled codes (symbols).")
164 ;; Put a property to each symbol of CCL codes for the disassembler.
165 (let (code (i 0) (len (length ccl-code-table)))
167 (setq code (aref ccl-code-table i))
168 (put code 'ccl-code i)
169 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
172 (let (code (i 0) (len (length ccl-extended-code-table)))
174 (setq code (aref ccl-extended-code-table i))
177 (put code 'ccl-ex-code i)
178 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))))
181 (defconst ccl-jump-code-list
182 '(jump jump-cond write-register-jump write-register-read-jump
183 write-const-jump write-const-read-jump write-string-jump
184 write-array-read-jump read-jump))
186 ;; Put a property `jump-flag' to each CCL code which execute jump in
188 (let ((l ccl-jump-code-list))
190 (put (car l) 'jump-flag t)
193 (defconst ccl-register-table
194 [r0 r1 r2 r3 r4 r5 r6 r7]
195 "Vector of CCL registers (symbols).")
197 ;; Put a property to indicate register number to each symbol of CCL.
199 (let (reg (i 0) (len (length ccl-register-table)))
201 (setq reg (aref ccl-register-table i))
202 (put reg 'ccl-register-number i)
205 (defconst ccl-arith-table
206 [+ - * / % & | ^ << >> <8 >8 // nil nil nil
207 < > == <= >= != de-sjis en-sjis]
208 "Vector of CCL arithmetic/logical operators (symbols).")
210 ;; Put a property to each symbol of CCL operators for the compiler.
211 (let (arith (i 0) (len (length ccl-arith-table)))
213 (setq arith (aref ccl-arith-table i))
214 (if arith (put arith 'ccl-arith-code i))
217 (defconst ccl-assign-arith-table
218 [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
219 "Vector of CCL assignment operators (symbols).")
221 ;; Put a property to each symbol of CCL assignment operators for the compiler.
222 (let (arith (i 0) (len (length ccl-assign-arith-table)))
224 (setq arith (aref ccl-assign-arith-table i))
225 (put arith 'ccl-self-arith-code i)
228 (defvar ccl-program-vector nil
229 "Working vector of CCL codes produced by CCL compiler.")
230 (defvar ccl-current-ic 0
231 "The current index for `ccl-program-vector'.")
233 ;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
234 ;; increment it. If IC is specified, embed DATA at IC.
235 (defun ccl-embed-data (data &optional ic)
236 (let ((val (if (characterp data) (char-int data) data)))
238 (aset ccl-program-vector ic val)
239 (aset ccl-program-vector ccl-current-ic val)
240 (setq ccl-current-ic (1+ ccl-current-ic)))))
242 ;; Embed string STR of length LEN in `ccl-program-vector' at
244 (defun ccl-embed-string (len str)
247 (ccl-embed-data (logior (ash (aref str i) 16)
249 (ash (aref str (1+ i)) 8)
256 ;; Embed a relative jump address to `ccl-current-ic' in
257 ;; `ccl-program-vector' at IC without altering the other bit field.
258 (defun ccl-embed-current-address (ic)
259 (let ((relative (- ccl-current-ic (1+ ic))))
260 (aset ccl-program-vector ic
261 (logior (aref ccl-program-vector ic) (ash relative 8)))))
263 ;; Embed CCL code for the operation OP and arguments REG and DATA in
264 ;; `ccl-program-vector' at `ccl-current-ic' in the following format.
265 ;; |----------------- integer (28-bit) ------------------|
266 ;; |------------ 20-bit ------------|- 3-bit --|- 5-bit -|
267 ;; |------------- DATA -------------|-- REG ---|-- OP ---|
268 ;; If REG2 is specified, embed a code in the following format.
269 ;; |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
270 ;; |-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
272 ;; If REG is a CCL register symbol (e.g. r0, r1...), the register
273 ;; number is embedded. If OP is one of unconditional jumps, DATA is
274 ;; changed to an relative jump address.
276 (defun ccl-embed-code (op reg data &optional reg2)
277 (if (and (> data 0) (get op 'jump-flag))
278 ;; DATA is an absolute jump address. Make it relative to the
279 ;; next of jump code.
280 (setq data (- data (1+ ccl-current-ic))))
281 (let ((code (logior (get op 'ccl-code)
283 (if (symbolp reg) (get reg 'ccl-register-number) reg) 5)
285 (logior (ash (get reg2 'ccl-register-number) 8)
288 (aset ccl-program-vector ccl-current-ic code)
289 (setq ccl-current-ic (1+ ccl-current-ic))))
291 ;; extended ccl command format
292 ;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
293 ;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|
294 (defun ccl-embed-extended-command (ex-op reg reg2 reg3)
295 (let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
297 (get reg3 'ccl-register-number)
299 (ccl-embed-code 'ex-cmd reg data reg2)))
301 ;; Just advance `ccl-current-ic' by INC.
302 (defun ccl-increment-ic (inc)
303 (setq ccl-current-ic (+ ccl-current-ic inc)))
306 (defun ccl-program-p (obj)
307 "T if OBJECT is a valid CCL compiled code."
309 (let ((i 0) (len (length obj)) (flag t))
312 (while (and flag (< i len))
313 (setq flag (integerp (aref obj i)))
317 ;; If non-nil, index of the start of the current loop.
318 (defvar ccl-loop-head nil)
319 ;; If non-nil, list of absolute addresses of the breaking points of
321 (defvar ccl-breaks nil)
324 (defun ccl-compile (ccl-program)
325 "Return a compiled code of CCL-PROGRAM as a vector of integer."
326 (if (or (null (consp ccl-program))
327 (null (integer-or-char-p (car ccl-program)))
328 (null (listp (car (cdr ccl-program)))))
329 (error "CCL: Invalid CCL program: %s" ccl-program))
330 (if (null (vectorp ccl-program-vector))
331 (setq ccl-program-vector (make-vector 8192 0)))
332 (setq ccl-loop-head nil ccl-breaks nil)
333 (setq ccl-current-ic 0)
335 ;; The first element is the buffer magnification.
336 (ccl-embed-data (car ccl-program))
338 ;; The second element is the address of the start CCL code for
339 ;; processing end of input buffer (we call it eof-processor). We
343 ;; Compile the main body of the CCL program.
344 (ccl-compile-1 (car (cdr ccl-program)))
346 ;; Embed the address of eof-processor.
347 (ccl-embed-data ccl-current-ic 1)
349 ;; Then compile eof-processor.
350 (if (nth 2 ccl-program)
351 (ccl-compile-1 (nth 2 ccl-program)))
353 ;; At last, embed termination code.
354 (ccl-embed-code 'end 0 0)
356 (let ((vec (make-vector ccl-current-ic 0))
358 (while (< i ccl-current-ic)
359 (aset vec i (aref ccl-program-vector i))
363 ;; Signal syntax error.
364 (defun ccl-syntax-error (cmd)
365 (error "CCL: Syntax error: %s" cmd))
367 ;; Check if ARG is a valid CCL register.
368 (defun ccl-check-register (arg cmd)
369 (if (get arg 'ccl-register-number)
371 (error "CCL: Invalid register %s in %s." arg cmd)))
373 ;; Check if ARG is a valid CCL command.
374 (defun ccl-check-compile-function (arg cmd)
375 (or (get arg 'ccl-compile-function)
376 (error "CCL: Invalid command: %s" cmd)))
378 ;; In the following code, most ccl-compile-XXXX functions return t if
379 ;; they end with unconditional jump, else return nil.
381 ;; Compile CCL-BLOCK (see the syntax above).
382 (defun ccl-compile-1 (ccl-block)
383 (let (unconditional-jump
385 (if (or (integer-or-char-p ccl-block)
387 (and ccl-block (symbolp (car ccl-block))))
388 ;; This block consists of single statement.
389 (setq ccl-block (list ccl-block)))
391 ;; Now CCL-BLOCK is a list of statements. Compile them one by
394 (setq cmd (car ccl-block))
395 (setq unconditional-jump
396 (cond ((integer-or-char-p cmd)
397 ;; SET statement for the register 0.
398 (ccl-compile-set (list 'r0 '= cmd)))
401 ;; WRITE statement of string argument.
402 (ccl-compile-write-string cmd))
405 ;; The other statements.
406 (cond ((eq (nth 1 cmd) '=)
407 ;; SET statement of the form `(REG = EXPRESSION)'.
408 (ccl-compile-set cmd))
410 ((and (symbolp (nth 1 cmd))
411 (get (nth 1 cmd) 'ccl-self-arith-code))
412 ;; SET statement with an assignment operation.
413 (ccl-compile-self-set cmd))
416 (funcall (ccl-check-compile-function (car cmd) cmd)
420 (ccl-syntax-error cmd))))
421 (setq ccl-block (cdr ccl-block)))
424 (defconst ccl-max-short-const (ash 1 19))
425 (defconst ccl-min-short-const (ash -1 19))
427 ;; Compile SET statement.
428 (defun ccl-compile-set (cmd)
429 (let ((rrr (ccl-check-register (car cmd) cmd))
432 ;; CMD has the form `(RRR = (XXX OP YYY))'.
433 (ccl-compile-expression rrr right))
435 ((integer-or-char-p right)
436 ;; CMD has the form `(RRR = integer)'.
437 (if (and (<= right ccl-max-short-const)
438 (>= right ccl-min-short-const))
439 (ccl-embed-code 'set-short-const rrr right)
440 (ccl-embed-code 'set-const rrr 0)
441 (ccl-embed-data right)))
444 ;; CMD has the form `(RRR = rrr [ array ])'.
445 (ccl-check-register right cmd)
446 (let ((ary (nth 3 cmd)))
448 (let ((i 0) (len (length ary)))
449 (ccl-embed-code 'set-array rrr len right)
451 (ccl-embed-data (aref ary i))
453 (ccl-embed-code 'set-register rrr 0 right))))))
456 ;; Compile SET statement with ASSIGNMENT_OPERATOR.
457 (defun ccl-compile-self-set (cmd)
458 (let ((rrr (ccl-check-register (car cmd) cmd))
461 ;; CMD has the form `(RRR ASSIGN_OP (XXX OP YYY))', compile
462 ;; the right hand part as `(r7 = (XXX OP YYY))' (note: the
463 ;; register 7 can be used for storing temporary value).
465 (ccl-compile-expression 'r7 right)
467 ;; Now CMD has the form `(RRR ASSIGN_OP ARG)'. Compile it as
468 ;; `(RRR = (RRR OP ARG))'.
469 (ccl-compile-expression
471 (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
474 ;; Compile SET statement of the form `(RRR = EXPR)'.
475 (defun ccl-compile-expression (rrr expr)
476 (let ((left (car expr))
477 (op (get (nth 1 expr) 'ccl-arith-code))
478 (right (nth 2 expr)))
481 ;; EXPR has the form `((EXPR2 OP2 ARG) OP RIGHT)'. Compile
482 ;; the first term as `(r7 = (EXPR2 OP2 ARG)).'
483 (ccl-compile-expression 'r7 left)
486 ;; Now EXPR has the form (LEFT OP RIGHT).
488 ;; Compile this SET statement as `(RRR OP= RIGHT)'.
489 (if (integer-or-char-p right)
491 (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
492 (ccl-embed-data right))
493 (ccl-check-register right expr)
494 (ccl-embed-code 'set-assign-expr-register rrr (ash op 3) right))
496 ;; Compile this SET statement as `(RRR = (LEFT OP RIGHT))'.
497 (if (integer-or-char-p right)
499 (ccl-embed-code 'set-expr-const rrr (ash op 3) left)
500 (ccl-embed-data right))
501 (ccl-check-register right expr)
502 (ccl-embed-code 'set-expr-register
504 (logior (ash op 3) (get right 'ccl-register-number))
507 ;; Compile WRITE statement with string argument.
508 (defun ccl-compile-write-string (str)
509 (let ((len (length str)))
510 (ccl-embed-code 'write-const-string 1 len)
511 (ccl-embed-string len str))
514 ;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
515 ;; If READ-FLAG is non-nil, this statement has the form
516 ;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'.
517 (defun ccl-compile-if (cmd &optional read-flag)
518 (if (and (/= (length cmd) 3) (/= (length cmd) 4))
519 (error "CCL: Invalid number of arguments: %s" cmd))
520 (let ((condition (nth 1 cmd))
521 (true-cmds (nth 2 cmd))
522 (false-cmds (nth 3 cmd))
525 (if (and (listp condition)
526 (listp (car condition)))
527 ;; If CONDITION is a nested expression, the inner expression
528 ;; should be compiled at first as SET statement, i.e.:
529 ;; `(if ((X OP2 Y) OP Z) ...)' is compiled into two statements:
530 ;; `(r7 = (X OP2 Y)) (if (r7 OP Z) ...)'.
532 (ccl-compile-expression 'r7 (car condition))
533 (setq condition (cons 'r7 (cdr condition)))
534 (setq cmd (cons (car cmd)
535 (cons condition (cdr (cdr cmd)))))))
537 (setq jump-cond-address ccl-current-ic)
538 ;; Compile CONDITION.
539 (if (symbolp condition)
540 ;; CONDITION is a register.
542 (ccl-check-register condition cmd)
543 (ccl-embed-code 'jump-cond condition 0))
544 ;; CONDITION is a simple expression of the form (RRR OP ARG).
545 (let ((rrr (car condition))
546 (op (get (nth 1 condition) 'ccl-arith-code))
547 (arg (nth 2 condition)))
548 (ccl-check-register rrr cmd)
549 (if (integer-or-char-p arg)
551 (ccl-embed-code (if read-flag 'read-jump-cond-expr-const
552 'jump-cond-expr-const)
555 (ccl-embed-data arg))
556 (ccl-check-register arg cmd)
557 (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
558 'jump-cond-expr-register)
561 (ccl-embed-data (get arg 'ccl-register-number)))))
563 ;; Compile TRUE-PART.
564 (let ((unconditional-jump (ccl-compile-1 true-cmds)))
565 (if (null false-cmds)
566 ;; This is the place to jump to if condition is false.
568 (ccl-embed-current-address jump-cond-address)
569 (setq unconditional-jump nil))
570 (let (end-true-part-address)
571 (if (not unconditional-jump)
573 ;; If TRUE-PART does not end with unconditional jump, we
574 ;; have to jump to the end of FALSE-PART from here.
575 (setq end-true-part-address ccl-current-ic)
576 (ccl-embed-code 'jump 0 0)))
577 ;; This is the place to jump to if CONDITION is false.
578 (ccl-embed-current-address jump-cond-address)
579 ;; Compile FALSE-PART.
580 (setq unconditional-jump
581 (and (ccl-compile-1 false-cmds) unconditional-jump))
582 (if end-true-part-address
583 ;; This is the place to jump to after the end of TRUE-PART.
584 (ccl-embed-current-address end-true-part-address))))
585 unconditional-jump)))
587 ;; Compile BRANCH statement.
588 (defun ccl-compile-branch (cmd)
589 (if (< (length cmd) 3)
590 (error "CCL: Invalid number of arguments: %s" cmd))
591 (ccl-compile-branch-blocks 'branch
592 (ccl-compile-branch-expression (nth 1 cmd) cmd)
595 ;; Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'.
596 (defun ccl-compile-read-branch (cmd)
597 (if (< (length cmd) 3)
598 (error "CCL: Invalid number of arguments: %s" cmd))
599 (ccl-compile-branch-blocks 'read-branch
600 (ccl-compile-branch-expression (nth 1 cmd) cmd)
603 ;; Compile EXPRESSION part of BRANCH statement and return register
604 ;; which holds a value of the expression.
605 (defun ccl-compile-branch-expression (expr cmd)
607 ;; EXPR has the form `(EXPR2 OP ARG)'. Compile it as SET
608 ;; statement of the form `(r7 = (EXPR2 OP ARG))'.
610 (ccl-compile-expression 'r7 expr)
612 (ccl-check-register expr cmd)))
614 ;; Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
615 ;; REG is a register which holds a value of EXPRESSION part. BLOCKs
616 ;; is a list of CCL-BLOCKs.
617 (defun ccl-compile-branch-blocks (code rrr blocks)
618 (let ((branches (length blocks))
620 jump-table-head-address
623 block-unconditional-jump)
624 (ccl-embed-code code rrr branches)
625 (setq jump-table-head-address ccl-current-ic)
626 ;; The size of jump table is the number of blocks plus 1 (for the
627 ;; case RRR is out of range).
628 (ccl-increment-ic (1+ branches))
629 (setq empty-block-indexes (list branches))
630 ;; Compile each block.
633 (if (null (car blocks))
634 ;; This block is empty.
635 (setq empty-block-indexes (cons branch-idx empty-block-indexes)
636 block-unconditional-jump t)
637 ;; This block is not empty.
638 (ccl-embed-data (- ccl-current-ic jump-table-head-address)
639 (+ jump-table-head-address branch-idx))
640 (setq block-unconditional-jump (ccl-compile-1 (car blocks)))
641 (if (not block-unconditional-jump)
643 ;; Jump address of the end of branches are embedded later.
644 ;; For the moment, just remember where to embed them.
645 (setq block-tail-addresses
646 (cons ccl-current-ic block-tail-addresses))
647 (ccl-embed-code 'jump 0 0))))
648 (setq branch-idx (1+ branch-idx))
649 (setq blocks (cdr blocks)))
650 (if (not block-unconditional-jump)
651 ;; We don't need jump code at the end of the last block.
652 (setq block-tail-addresses (cdr block-tail-addresses)
653 ccl-current-ic (1- ccl-current-ic)))
654 ;; Embed jump address at the tailing jump commands of blocks.
655 (while block-tail-addresses
656 (ccl-embed-current-address (car block-tail-addresses))
657 (setq block-tail-addresses (cdr block-tail-addresses)))
658 ;; For empty blocks, make entries in the jump table point directly here.
659 (while empty-block-indexes
660 (ccl-embed-data (- ccl-current-ic jump-table-head-address)
661 (+ jump-table-head-address (car empty-block-indexes)))
662 (setq empty-block-indexes (cdr empty-block-indexes))))
663 ;; Branch command ends by unconditional jump if RRR is out of range.
666 ;; Compile LOOP statement.
667 (defun ccl-compile-loop (cmd)
668 (if (< (length cmd) 2)
669 (error "CCL: Invalid number of arguments: %s" cmd))
670 (let* ((ccl-loop-head ccl-current-ic)
676 (setq unconditional-jump t)
678 (setq unconditional-jump
679 (and (ccl-compile-1 (car cmd)) unconditional-jump))
680 (setq cmd (cdr cmd)))
683 ;; Embed jump address for break statements encountered in
686 (ccl-embed-current-address (car ccl-breaks))
687 (setq ccl-breaks (cdr ccl-breaks))))
690 ;; Compile BREAK statement.
691 (defun ccl-compile-break (cmd)
692 (if (/= (length cmd) 1)
693 (error "CCL: Invalid number of arguments: %s" cmd))
694 (if (null ccl-loop-head)
695 (error "CCL: No outer loop: %s" cmd))
696 (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
697 (ccl-embed-code 'jump 0 0)
700 ;; Compile REPEAT statement.
701 (defun ccl-compile-repeat (cmd)
702 (if (/= (length cmd) 1)
703 (error "CCL: Invalid number of arguments: %s" cmd))
704 (if (null ccl-loop-head)
705 (error "CCL: No outer loop: %s" cmd))
706 (ccl-embed-code 'jump 0 ccl-loop-head)
709 ;; Compile WRITE-REPEAT statement.
710 (defun ccl-compile-write-repeat (cmd)
711 (if (/= (length cmd) 2)
712 (error "CCL: Invalid number of arguments: %s" cmd))
713 (if (null ccl-loop-head)
714 (error "CCL: No outer loop: %s" cmd))
715 (let ((arg (nth 1 cmd)))
716 (cond ((integer-or-char-p arg)
717 (ccl-embed-code 'write-const-jump 0 ccl-loop-head)
718 (ccl-embed-data arg))
720 (let ((len (length arg))
722 (ccl-embed-code 'write-string-jump 0 ccl-loop-head)
724 (ccl-embed-string len arg)))
726 (ccl-check-register arg cmd)
727 (ccl-embed-code 'write-register-jump arg ccl-loop-head))))
730 ;; Compile WRITE-READ-REPEAT statement.
731 (defun ccl-compile-write-read-repeat (cmd)
732 (if (or (< (length cmd) 2) (> (length cmd) 3))
733 (error "CCL: Invalid number of arguments: %s" cmd))
734 (if (null ccl-loop-head)
735 (error "CCL: No outer loop: %s" cmd))
736 (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
739 (ccl-embed-code 'write-register-read-jump rrr ccl-loop-head))
740 ((integer-or-char-p arg)
741 (ccl-embed-code 'write-const-read-jump rrr arg ccl-loop-head))
743 (let ((len (length arg))
745 (ccl-embed-code 'write-array-read-jump rrr ccl-loop-head)
748 (ccl-embed-data (aref arg i))
751 (error "CCL: Invalid argument %s: %s" arg cmd)))
752 (ccl-embed-code 'read-jump rrr ccl-loop-head))
755 ;; Compile READ statement.
756 (defun ccl-compile-read (cmd)
757 (if (< (length cmd) 2)
758 (error "CCL: Invalid number of arguments: %s" cmd))
759 (let* ((args (cdr cmd))
760 (i (1- (length args))))
762 (let ((rrr (ccl-check-register (car args) cmd)))
763 (ccl-embed-code 'read-register rrr i)
764 (setq args (cdr args) i (1- i)))))
767 ;; Compile READ-IF statement.
768 (defun ccl-compile-read-if (cmd)
769 (ccl-compile-if cmd 'read))
771 ;; Compile WRITE statement.
772 (defun ccl-compile-write (cmd)
773 (if (< (length cmd) 2)
774 (error "CCL: Invalid number of arguments: %s" cmd))
775 (let ((rrr (nth 1 cmd)))
776 (cond ((integer-or-char-p rrr)
777 (ccl-embed-code 'write-const-string 0 rrr))
779 (ccl-compile-write-string rrr))
780 ((and (symbolp rrr) (vectorp (nth 2 cmd)))
781 (ccl-check-register rrr cmd)
782 ;; CMD has the form `(write REG ARRAY)'.
783 (let* ((arg (nth 2 cmd))
786 (ccl-embed-code 'write-array rrr len)
788 (if (not (integer-or-char-p (aref arg i)))
789 (error "CCL: Invalid argument %s: %s" arg cmd))
790 (ccl-embed-data (aref arg i))
794 ;; CMD has the form `(write REG ...)'.
795 (let* ((args (cdr cmd))
796 (i (1- (length args))))
798 (setq rrr (ccl-check-register (car args) cmd))
799 (ccl-embed-code 'write-register rrr i)
800 (setq args (cdr args) i (1- i)))))
803 ;; CMD has the form `(write (LEFT OP RIGHT))'.
804 (let ((left (car rrr))
805 (op (get (nth 1 rrr) 'ccl-arith-code))
809 ;; RRR has the form `((EXPR OP2 ARG) OP RIGHT)'.
810 ;; Compile the first term as `(r7 = (EXPR OP2 ARG))'.
811 (ccl-compile-expression 'r7 left)
813 ;; Now RRR has the form `(ARG OP RIGHT)'.
814 (if (integer-or-char-p right)
816 (ccl-embed-code 'write-expr-const 0 (ash op 3) left)
817 (ccl-embed-data right))
818 (ccl-check-register right rrr)
819 (ccl-embed-code 'write-expr-register 0
821 (get right 'ccl-register-number))))))
824 (error "CCL: Invalid argument: %s" cmd))))
827 ;; Compile CALL statement.
828 (defun ccl-compile-call (cmd)
829 (if (/= (length cmd) 2)
830 (error "CCL: Invalid number of arguments: %s" cmd))
831 (if (not (symbolp (nth 1 cmd)))
832 (error "CCL: Subroutine should be a symbol: %s" cmd))
833 (let* ((name (nth 1 cmd))
834 (idx (get name 'ccl-program-idx)))
836 (error "CCL: Unknown subroutine name: %s" name))
837 (ccl-embed-code 'call 0 idx))
840 ;; Compile END statement.
841 (defun ccl-compile-end (cmd)
842 (if (/= (length cmd) 1)
843 (error "CCL: Invalid number of arguments: %s" cmd))
844 (ccl-embed-code 'end 0 0)
847 ;; Compile read-multibyte-character
848 (defun ccl-compile-read-multibyte-character (cmd)
849 (if (/= (length cmd) 3)
850 (error "CCL: Invalid number of arguments: %s" cmd))
851 (let ((RRR (nth 1 cmd))
853 (ccl-check-register rrr cmd)
854 (ccl-check-register RRR cmd)
855 (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
858 ;; Compile write-multibyte-character
859 (defun ccl-compile-write-multibyte-character (cmd)
860 (if (/= (length cmd) 3)
861 (error "CCL: Invalid number of arguments: %s" cmd))
862 (let ((RRR (nth 1 cmd))
864 (ccl-check-register rrr cmd)
865 (ccl-check-register RRR cmd)
866 (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
869 ;; Compile translate-character
870 ;; (defun ccl-compile-translate-character (cmd)
871 ;; (if (/= (length cmd) 4)
872 ;; (error "CCL: Invalid number of arguments: %s" cmd))
873 ;; (let ((Rrr (nth 1 cmd))
875 ;; (rrr (nth 3 cmd)))
876 ;; (ccl-check-register rrr cmd)
877 ;; (ccl-check-register RRR cmd)
878 ;; (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
879 ;; (if (not (get Rrr 'translation-table))
880 ;; (error "CCL: Invalid translation table %s in %s" Rrr cmd))
881 ;; (ccl-embed-extended-command 'translate-character-const-tbl
883 ;; (ccl-embed-data Rrr))
885 ;; (ccl-check-register Rrr cmd)
886 ;; (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
889 ;; (defun ccl-compile-iterate-multiple-map (cmd)
890 ;; (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
893 ;; (defun ccl-compile-map-multiple (cmd)
894 ;; (if (/= (length cmd) 4)
895 ;; (error "CCL: Invalid number of arguments: %s" cmd))
896 ;; (let ((func '(lambda (arg mp)
897 ;; (let ((len 0) result add)
899 ;; (if (consp (car arg))
900 ;; (setq add (funcall func (car arg) t)
901 ;; result (append result add)
902 ;; add (+ (-(car add)) 1))
907 ;; (setq arg (cdr arg)
910 ;; (cons (- len) result)
913 ;; (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
914 ;; (funcall func (nth 3 cmd) nil)))
915 ;; (ccl-compile-multiple-map-function 'map-multiple arg))
918 ;; (defun ccl-compile-map-single (cmd)
919 ;; (if (/= (length cmd) 4)
920 ;; (error "CCL: Invalid number of arguments: %s" cmd))
921 ;; (let ((RRR (nth 1 cmd))
925 ;; (ccl-check-register rrr cmd)
926 ;; (ccl-check-register RRR cmd)
927 ;; (ccl-embed-extended-command 'map-single rrr RRR 0)
928 ;; (cond ((symbolp map)
929 ;; (if (get map 'code-conversion-map)
930 ;; (ccl-embed-data map)
931 ;; (error "CCL: Invalid map: %s" map)))
933 ;; (error "CCL: Invalid type of arguments: %s" cmd))))
936 ;; (defun ccl-compile-multiple-map-function (command cmd)
937 ;; (if (< (length cmd) 4)
938 ;; (error "CCL: Invalid number of arguments: %s" cmd))
939 ;; (let ((RRR (nth 1 cmd))
941 ;; (args (nthcdr 3 cmd))
943 ;; (ccl-check-register rrr cmd)
944 ;; (ccl-check-register RRR cmd)
945 ;; (ccl-embed-extended-command command rrr RRR 0)
946 ;; (ccl-embed-data (length args))
948 ;; (setq map (car args))
949 ;; (cond ((symbolp map)
950 ;; (if (get map 'code-conversion-map)
951 ;; (ccl-embed-data map)
952 ;; (error "CCL: Invalid map: %s" map)))
954 ;; (ccl-embed-data map))
956 ;; (error "CCL: Invalid type of arguments: %s" cmd)))
957 ;; (setq args (cdr args)))))
962 ;; To avoid byte-compiler warning.
966 (defun ccl-dump (ccl-code)
967 "Disassemble compiled CCL-CODE."
968 (let ((len (length ccl-code))
969 (buffer-mag (aref ccl-code 0)))
970 (cond ((= buffer-mag 0)
971 (insert "Don't output anything.\n"))
973 (insert "Out-buffer must be as large as in-buffer.\n"))
976 (format "Out-buffer must be %d times bigger than in-buffer.\n"
978 (insert "Main-body:\n")
979 (setq ccl-current-ic 2)
980 (if (> (aref ccl-code 1) 0)
982 (while (< ccl-current-ic (aref ccl-code 1))
984 (insert "At EOF:\n")))
985 (while (< ccl-current-ic len)
989 ;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
990 (defun ccl-get-next-code ()
992 (aref ccl-code ccl-current-ic)
993 (setq ccl-current-ic (1+ ccl-current-ic))))
996 (let* ((code (ccl-get-next-code))
997 (cmd (aref ccl-code-table (logand code 31)))
998 (rrr (ash (logand code 255) -5))
1000 (insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
1001 (funcall (get cmd 'ccl-dump-function) rrr cc)))
1003 (defun ccl-dump-set-register (rrr cc)
1004 (insert (format "r%d = r%d\n" rrr cc)))
1006 (defun ccl-dump-set-short-const (rrr cc)
1007 (insert (format "r%d = %d\n" rrr cc)))
1009 (defun ccl-dump-set-const (rrr ignore)
1010 (insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
1012 (defun ccl-dump-set-array (rrr cc)
1013 (let ((rrr2 (logand cc 7))
1016 (insert (format "r%d = array[r%d] of length %d\n\t"
1019 (insert (format "%d " (ccl-get-next-code)))
1023 (defun ccl-dump-jump (ignore cc &optional address)
1024 (insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
1027 (insert (format "%d)\n" (1+ cc))))
1029 (defun ccl-dump-jump-cond (rrr cc)
1030 (insert (format "if (r%d == 0), " rrr))
1031 (ccl-dump-jump nil cc))
1033 (defun ccl-dump-write-register-jump (rrr cc)
1034 (insert (format "write r%d, " rrr))
1035 (ccl-dump-jump nil cc))
1037 (defun ccl-dump-write-register-read-jump (rrr cc)
1038 (insert (format "write r%d, read r%d, " rrr rrr))
1039 (ccl-dump-jump nil cc)
1040 (ccl-get-next-code) ; Skip dummy READ-JUMP
1043 (defun ccl-extract-arith-op (cc)
1044 (aref ccl-arith-table (ash cc -6)))
1046 (defun ccl-dump-write-expr-const (ignore cc)
1047 (insert (format "write (r%d %s %d)\n"
1049 (ccl-extract-arith-op cc)
1050 (ccl-get-next-code))))
1052 (defun ccl-dump-write-expr-register (ignore cc)
1053 (insert (format "write (r%d %s r%d)\n"
1055 (ccl-extract-arith-op cc)
1056 (logand (ash cc -3) 7))))
1058 (defun ccl-dump-insert-char (cc)
1059 (cond ((= cc ?\t) (insert " \"^I\""))
1060 ((= cc ?\n) (insert " \"^J\""))
1061 (t (insert (format " \"%c\"" cc)))))
1063 (defun ccl-dump-write-const-jump (ignore cc)
1064 (let ((address ccl-current-ic))
1065 (insert "write char")
1066 (ccl-dump-insert-char (ccl-get-next-code))
1068 (ccl-dump-jump nil cc address)))
1070 (defun ccl-dump-write-const-read-jump (rrr cc)
1071 (let ((address ccl-current-ic))
1072 (insert "write char")
1073 (ccl-dump-insert-char (ccl-get-next-code))
1074 (insert (format ", read r%d, " rrr))
1075 (ccl-dump-jump cc address)
1076 (ccl-get-next-code) ; Skip dummy READ-JUMP
1079 (defun ccl-dump-write-string-jump (ignore cc)
1080 (let ((address ccl-current-ic)
1081 (len (ccl-get-next-code))
1085 (let ((code (ccl-get-next-code)))
1086 (insert (ash code -16))
1087 (if (< (1+ i) len) (insert (logand (ash code -8) 255)))
1088 (if (< (+ i 2) len) (insert (logand code 255))))
1091 (ccl-dump-jump nil cc address)))
1093 (defun ccl-dump-write-array-read-jump (rrr cc)
1094 (let ((address ccl-current-ic)
1095 (len (ccl-get-next-code))
1097 (insert (format "write array[r%d] of length %d,\n\t" rrr len))
1099 (ccl-dump-insert-char (ccl-get-next-code))
1101 (insert (format "\n\tthen read r%d, " rrr))
1102 (ccl-dump-jump nil cc address)
1103 (ccl-get-next-code) ; Skip dummy READ-JUMP.
1106 (defun ccl-dump-read-jump (rrr cc)
1107 (insert (format "read r%d, " rrr))
1108 (ccl-dump-jump nil cc))
1110 (defun ccl-dump-branch (rrr len)
1111 (let ((jump-table-head ccl-current-ic)
1113 (insert (format "jump to array[r%d] of length %d\n\t" rrr len))
1115 (insert (format "%d " (+ jump-table-head (ccl-get-next-code))))
1119 (defun ccl-dump-read-register (rrr cc)
1120 (insert (format "read r%d (%d remaining)\n" rrr cc)))
1122 (defun ccl-dump-read-branch (rrr len)
1123 (insert (format "read r%d, " rrr))
1124 (ccl-dump-branch rrr len))
1126 (defun ccl-dump-write-register (rrr cc)
1127 (insert (format "write r%d (%d remaining)\n" rrr cc)))
1129 (defun ccl-dump-call (ignore cc)
1130 (insert (format "call subroutine #%d\n" cc)))
1132 (defun ccl-dump-write-const-string (rrr cc)
1135 (insert "write char")
1136 (ccl-dump-insert-char cc)
1142 (let ((code (ccl-get-next-code)))
1143 (insert (format "%c" (lsh code -16)))
1145 (insert (format "%c" (logand (lsh code -8) 255))))
1147 (insert (format "%c" (logand code 255))))
1151 (defun ccl-dump-write-array (rrr cc)
1153 (insert (format "write array[r%d] of length %d\n\t" rrr cc))
1155 (ccl-dump-insert-char (ccl-get-next-code))
1159 (defun ccl-dump-end (&rest ignore)
1162 (defun ccl-dump-set-assign-expr-const (rrr cc)
1163 (insert (format "r%d %s= %d\n"
1165 (ccl-extract-arith-op cc)
1166 (ccl-get-next-code))))
1168 (defun ccl-dump-set-assign-expr-register (rrr cc)
1169 (insert (format "r%d %s= r%d\n"
1171 (ccl-extract-arith-op cc)
1174 (defun ccl-dump-set-expr-const (rrr cc)
1175 (insert (format "r%d = r%d %s %d\n"
1178 (ccl-extract-arith-op cc)
1179 (ccl-get-next-code))))
1181 (defun ccl-dump-set-expr-register (rrr cc)
1182 (insert (format "r%d = r%d %s r%d\n"
1185 (ccl-extract-arith-op cc)
1186 (logand (ash cc -3) 7))))
1188 (defun ccl-dump-jump-cond-expr-const (rrr cc)
1189 (let ((address ccl-current-ic))
1190 (insert (format "if !(r%d %s %d), "
1192 (aref ccl-arith-table (ccl-get-next-code))
1193 (ccl-get-next-code)))
1194 (ccl-dump-jump nil cc address)))
1196 (defun ccl-dump-jump-cond-expr-register (rrr cc)
1197 (let ((address ccl-current-ic))
1198 (insert (format "if !(r%d %s r%d), "
1200 (aref ccl-arith-table (ccl-get-next-code))
1201 (ccl-get-next-code)))
1202 (ccl-dump-jump nil cc address)))
1204 (defun ccl-dump-read-jump-cond-expr-const (rrr cc)
1205 (insert (format "read r%d, " rrr))
1206 (ccl-dump-jump-cond-expr-const rrr cc))
1208 (defun ccl-dump-read-jump-cond-expr-register (rrr cc)
1209 (insert (format "read r%d, " rrr))
1210 (ccl-dump-jump-cond-expr-register rrr cc))
1212 (defun ccl-dump-binary (ccl-code)
1213 (let ((len (length ccl-code))
1216 (let ((code (aref ccl-code i))
1219 (insert (if (= (logand code (ash 1 j)) 0) ?0 ?1))
1221 (setq code (logand code 31))
1222 (if (< code (length ccl-code-table))
1223 (insert (format ":%s" (aref ccl-code-table code))))
1227 (defun ccl-dump-ex-cmd (rrr cc)
1228 (let* ((RRR (logand cc ?\x7))
1229 (Rrr (logand (ash cc -3) ?\x7))
1230 (ex-op (aref ccl-extended-code-table (logand (ash cc -6) ?\x3fff))))
1231 (insert (format "<%s> " ex-op))
1232 (funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
1234 (defun ccl-dump-read-multibyte-character (rrr RRR Rrr)
1235 (insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
1237 (defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
1238 (insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
1240 ;; (defun ccl-dump-translate-character (rrr RRR Rrr)
1241 ;; (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
1243 ;; (defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
1244 ;; (let ((tbl (ccl-get-next-code)))
1245 ;; (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
1247 ;; (defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
1248 ;; (let ((notbl (ccl-get-next-code))
1250 ;; (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
1251 ;; (insert (format "\tnumber of maps is %d .\n\t [" notbl))
1252 ;; (while (< i notbl)
1253 ;; (setq id (ccl-get-next-code))
1254 ;; (insert (format "%S" id))
1258 ;; (defun ccl-dump-map-multiple (rrr RRR Rrr)
1259 ;; (let ((notbl (ccl-get-next-code))
1261 ;; (insert (format "map-multiple r%d r%d\n" RRR rrr))
1262 ;; (insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
1263 ;; (while (< i notbl)
1264 ;; (setq id (ccl-get-next-code))
1266 ;; (insert "]\n\t [")
1267 ;; (insert (format "%S " id)))
1271 ;; (defun ccl-dump-map-single (rrr RRR Rrr)
1272 ;; (let ((id (ccl-get-next-code)))
1273 ;; (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
1276 ;; CCL emulation staffs
1278 ;; Not yet implemented.
1280 ;; Auto-loaded functions.
1283 (defmacro declare-ccl-program (name &optional vector)
1284 "Declare NAME as a name of CCL program.
1286 To compile a CCL program which calls another CCL program not yet
1287 defined, it must be declared as a CCL program in advance.
1288 Optional arg VECTOR is a compiled CCL code of the CCL program."
1289 `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
1292 (defmacro define-ccl-program (name ccl-program &optional doc)
1293 "Set NAME the compiled code of CCL-PROGRAM.
1294 CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'.
1295 The compiled code is a vector of integers."
1296 `(let ((prog ,(ccl-compile (eval ccl-program))))
1297 (defconst ,name prog ,doc)
1298 (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
1302 (defmacro check-ccl-program (ccl-program &optional name)
1303 "Check validity of CCL-PROGRAM.
1304 If CCL-PROGRAM is a symbol denoting a valid CCL program, return
1305 CCL-PROGRAM, else return nil.
1306 If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
1307 register CCL-PROGRAM by name NAME, and return NAME."
1308 `(let ((result ,ccl-program))
1309 (cond ((symbolp ,ccl-program)
1310 (or (numberp (get ,ccl-program 'ccl-program-idx))
1312 ((vectorp ,ccl-program)
1314 (register-ccl-program result ,ccl-program))
1320 (defun ccl-execute-with-args (ccl-prog &rest args)
1321 "Execute CCL-PROGRAM with registers initialized by the remaining args.
1322 The return value is a vector of resulting CCL registers."
1323 (let ((reg (make-vector 8 0))
1325 (while (and args (< i 8))
1326 (if (not (integerp (car args)))
1327 (error "Arguments should be integer"))
1328 (aset reg i (car args))
1329 (setq args (cdr args) i (1+ i)))
1330 (ccl-execute ccl-prog reg)