Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-ccl.el @ 444:576fb035e263 r21-2-37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-37
author cvs
date Mon, 13 Aug 2007 11:36:19 +0200
parents abe6d1db359e
children 98528da0b7fc
comparison
equal deleted inserted replaced
443:a8296e22da4e 444:576fb035e263
20 ;; You should have received a copy of the GNU General Public License 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 21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24 24
25 ;; Synched up with: FSF 20.2 25 ;; Synched up with: FSF 21.0.90
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;; CCL (Code Conversion Language) is a simple programming language to 29 ;; CCL (Code Conversion Language) is a simple programming language to
30 ;; be used for various kind of code conversion. CCL program is 30 ;; be used for various kind of code conversion. CCL program is
37 ;; However, since CCL is designed as a powerful programming language, 37 ;; However, since CCL is designed as a powerful programming language,
38 ;; it can be used for more generic calculation. For instance, 38 ;; it can be used for more generic calculation. For instance,
39 ;; combination of three or more arithmetic operations can be 39 ;; combination of three or more arithmetic operations can be
40 ;; calculated faster than Emacs Lisp. 40 ;; calculated faster than Emacs Lisp.
41 ;; 41 ;;
42 ;; Here's the syntax of CCL program in BNF notation. 42 ;; Syntax and semantics of CCL program is described in the
43 ;; 43 ;; documentation of `define-ccl-program'.
44 ;; CCL_PROGRAM :=
45 ;; (BUFFER_MAGNIFICATION
46 ;; CCL_MAIN_BLOCK
47 ;; [ CCL_EOF_BLOCK ])
48 ;;
49 ;; BUFFER_MAGNIFICATION := integer
50 ;; CCL_MAIN_BLOCK := CCL_BLOCK
51 ;; CCL_EOF_BLOCK := CCL_BLOCK
52 ;;
53 ;; CCL_BLOCK :=
54 ;; STATEMENT | (STATEMENT [STATEMENT ...])
55 ;; STATEMENT :=
56 ;; SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
57 ;;
58 ;; SET :=
59 ;; (REG = EXPRESSION)
60 ;; | (REG ASSIGNMENT_OPERATOR EXPRESSION)
61 ;; | integer
62 ;;
63 ;; EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
64 ;;
65 ;; IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK)
66 ;; BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...])
67 ;; LOOP := (loop STATEMENT [STATEMENT ...])
68 ;; BREAK := (break)
69 ;; REPEAT :=
70 ;; (repeat)
71 ;; | (write-repeat [REG | integer | string])
72 ;; | (write-read-repeat REG [integer | ARRAY])
73 ;; READ :=
74 ;; (read REG ...)
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})
78 ;; WRITE :=
79 ;; (write REG ...)
80 ;; | (write EXPRESSION)
81 ;; | (write integer) | (write string) | (write REG ARRAY)
82 ;; | string
83 ;; | (write-multibyte-character REG(charset) REG(codepoint))
84 ;; CALL := (call ccl-program-name)
85 ;; END := (end)
86 ;;
87 ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
88 ;; ARG := REG | integer
89 ;; OPERATOR :=
90 ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
91 ;; | < | > | == | <= | >= | != | de-sjis | en-sjis
92 ;; ASSIGNMENT_OPERATOR :=
93 ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
94 ;; ARRAY := '[' integer ... ']'
95 44
96 ;;; Code: 45 ;;; Code:
97 46
98 (defconst ccl-command-table 47 (defconst ccl-command-table
99 [if branch loop break repeat write-repeat write-read-repeat 48 [if branch loop break repeat write-repeat write-read-repeat
100 read read-if read-branch write call end 49 read read-if read-branch write call end
101 read-multibyte-character write-multibyte-character] 50 read-multibyte-character write-multibyte-character
51 translate-character
52 iterate-multiple-map map-multiple map-single]
102 "Vector of CCL commands (symbols).") 53 "Vector of CCL commands (symbols).")
103 54
104 ;; Put a property to each symbol of CCL commands for the compiler. 55 ;; Put a property to each symbol of CCL commands for the compiler.
105 (let (op (i 0) (len (length ccl-command-table))) 56 (let (op (i 0) (len (length ccl-command-table)))
106 (while (< i len) 57 (while (< i len)
226 "The current index for `ccl-program-vector'.") 177 "The current index for `ccl-program-vector'.")
227 178
228 ;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and 179 ;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
229 ;; increment it. If IC is specified, embed DATA at IC. 180 ;; increment it. If IC is specified, embed DATA at IC.
230 (defun ccl-embed-data (data &optional ic) 181 (defun ccl-embed-data (data &optional ic)
231 (let ((val (if (characterp data) (char-int data) data))) 182 (if (characterp data)
232 (if ic 183 (setq data (char-int data)))
233 (aset ccl-program-vector ic val) 184 (if ic
234 (aset ccl-program-vector ccl-current-ic val) 185 (aset ccl-program-vector ic data)
235 (setq ccl-current-ic (1+ ccl-current-ic))))) 186 (let ((len (length ccl-program-vector)))
187 (if (>= ccl-current-ic len)
188 (let ((new (make-vector (* len 2) nil)))
189 (while (> len 0)
190 (setq len (1- len))
191 (aset new len (aref ccl-program-vector len)))
192 (setq ccl-program-vector new))))
193 (aset ccl-program-vector ccl-current-ic data)
194 (setq ccl-current-ic (1+ ccl-current-ic))))
195
196 ;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
197 ;; proper index number for SYMBOL. PROP should be
198 ;; `translation-table-id', `code-conversion-map-id', or
199 ;; `ccl-program-idx'.
200 (defun ccl-embed-symbol (symbol prop)
201 (ccl-embed-data (cons symbol prop)))
236 202
237 ;; Embed string STR of length LEN in `ccl-program-vector' at 203 ;; Embed string STR of length LEN in `ccl-program-vector' at
238 ;; `ccl-current-ic'. 204 ;; `ccl-current-ic'.
239 (defun ccl-embed-string (len str) 205 (defun ccl-embed-string (len str)
240 (let ((i 0)) 206 (let ((i 0))
278 (if (symbolp reg) (get reg 'ccl-register-number) reg) 5) 244 (if (symbolp reg) (get reg 'ccl-register-number) reg) 5)
279 (if reg2 245 (if reg2
280 (logior (ash (get reg2 'ccl-register-number) 8) 246 (logior (ash (get reg2 'ccl-register-number) 8)
281 (ash data 11)) 247 (ash data 11))
282 (ash data 8))))) 248 (ash data 8)))))
283 (aset ccl-program-vector ccl-current-ic code) 249 (ccl-embed-data code)))
284 (setq ccl-current-ic (1+ ccl-current-ic))))
285 250
286 ;; extended ccl command format 251 ;; extended ccl command format
287 ;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -| 252 ;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
288 ;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---| 253 ;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|
289 (defun ccl-embed-extended-command (ex-op reg reg2 reg3) 254 (defun ccl-embed-extended-command (ex-op reg reg2 reg3)
295 260
296 ;; Just advance `ccl-current-ic' by INC. 261 ;; Just advance `ccl-current-ic' by INC.
297 (defun ccl-increment-ic (inc) 262 (defun ccl-increment-ic (inc)
298 (setq ccl-current-ic (+ ccl-current-ic inc))) 263 (setq ccl-current-ic (+ ccl-current-ic inc)))
299 264
300 ;;;###autoload
301 (defun ccl-program-p (obj)
302 "Return t if OBJECT is a valid CCL compiled code."
303 (and (vectorp obj)
304 (let ((i 0) (len (length obj)) (flag t))
305 (if (> len 1)
306 (progn
307 (while (and flag (< i len))
308 (setq flag (integerp (aref obj i)))
309 (setq i (1+ i)))
310 flag)))))
311
312 ;; If non-nil, index of the start of the current loop. 265 ;; If non-nil, index of the start of the current loop.
313 (defvar ccl-loop-head nil) 266 (defvar ccl-loop-head nil)
314 ;; If non-nil, list of absolute addresses of the breaking points of 267 ;; If non-nil, list of absolute addresses of the breaking points of
315 ;; the current loop. 268 ;; the current loop.
316 (defvar ccl-breaks nil) 269 (defvar ccl-breaks nil)
317 270
318 ;;;###autoload 271 ;;;###autoload
319 (defun ccl-compile (ccl-program) 272 (defun ccl-compile (ccl-program)
320 "Return a compiled code of CCL-PROGRAM as a vector of integer." 273 "Return a compiled code of CCL-PROGRAM as a vector of integer."
321 (if (or (null (consp ccl-program)) 274 (if (or (null (consp ccl-program))
322 (null (integer-or-char-p (car ccl-program))) 275 (null (integerp (car ccl-program)))
323 (null (listp (car (cdr ccl-program))))) 276 (null (listp (car (cdr ccl-program)))))
324 (error "CCL: Invalid CCL program: %s" ccl-program)) 277 (error "CCL: Invalid CCL program: %s" ccl-program))
325 (if (null (vectorp ccl-program-vector)) 278 (if (null (vectorp ccl-program-vector))
326 (setq ccl-program-vector (make-vector 8192 0))) 279 (setq ccl-program-vector (make-vector 8192 0)))
327 (setq ccl-loop-head nil ccl-breaks nil) 280 (setq ccl-loop-head nil ccl-breaks nil)
477 ;; the first term as `(r7 = (EXPR2 OP2 ARG)).' 430 ;; the first term as `(r7 = (EXPR2 OP2 ARG)).'
478 (ccl-compile-expression 'r7 left) 431 (ccl-compile-expression 'r7 left)
479 (setq left 'r7))) 432 (setq left 'r7)))
480 433
481 ;; Now EXPR has the form (LEFT OP RIGHT). 434 ;; Now EXPR has the form (LEFT OP RIGHT).
482 (if (eq rrr left) 435 (if (and (eq rrr left)
436 (< op (length ccl-assign-arith-table)))
483 ;; Compile this SET statement as `(RRR OP= RIGHT)'. 437 ;; Compile this SET statement as `(RRR OP= RIGHT)'.
484 (if (integer-or-char-p right) 438 (if (integer-or-char-p right)
485 (progn 439 (progn
486 (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0) 440 (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
487 (ccl-embed-data right)) 441 (ccl-embed-data right))
499 (logior (ash op 3) (get right 'ccl-register-number)) 453 (logior (ash op 3) (get right 'ccl-register-number))
500 left))))) 454 left)))))
501 455
502 ;; Compile WRITE statement with string argument. 456 ;; Compile WRITE statement with string argument.
503 (defun ccl-compile-write-string (str) 457 (defun ccl-compile-write-string (str)
458 (setq str (encode-coding-string str 'binary))
504 (let ((len (length str))) 459 (let ((len (length str)))
505 (ccl-embed-code 'write-const-string 1 len) 460 (ccl-embed-code 'write-const-string 1 len)
506 (ccl-embed-string len str)) 461 (ccl-embed-string len str))
507 nil) 462 nil)
508 463
710 (let ((arg (nth 1 cmd))) 665 (let ((arg (nth 1 cmd)))
711 (cond ((integer-or-char-p arg) 666 (cond ((integer-or-char-p arg)
712 (ccl-embed-code 'write-const-jump 0 ccl-loop-head) 667 (ccl-embed-code 'write-const-jump 0 ccl-loop-head)
713 (ccl-embed-data arg)) 668 (ccl-embed-data arg))
714 ((stringp arg) 669 ((stringp arg)
670 (setq arg (encode-coding-string arg 'binary))
715 (let ((len (length arg)) 671 (let ((len (length arg))
716 (i 0)) 672 (i 0))
717 (ccl-embed-code 'write-string-jump 0 ccl-loop-head) 673 (ccl-embed-code 'write-string-jump 0 ccl-loop-head)
718 (ccl-embed-data len) 674 (ccl-embed-data len)
719 (ccl-embed-string len arg))) 675 (ccl-embed-string len arg)))
823 (defun ccl-compile-call (cmd) 779 (defun ccl-compile-call (cmd)
824 (if (/= (length cmd) 2) 780 (if (/= (length cmd) 2)
825 (error "CCL: Invalid number of arguments: %s" cmd)) 781 (error "CCL: Invalid number of arguments: %s" cmd))
826 (if (not (symbolp (nth 1 cmd))) 782 (if (not (symbolp (nth 1 cmd)))
827 (error "CCL: Subroutine should be a symbol: %s" cmd)) 783 (error "CCL: Subroutine should be a symbol: %s" cmd))
828 (let* ((name (nth 1 cmd)) 784 (ccl-embed-code 'call 1 0)
829 (idx (get name 'ccl-program-idx))) 785 (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx)
830 (if (not idx)
831 (error "CCL: Unknown subroutine name: %s" name))
832 (ccl-embed-code 'call 0 idx))
833 nil) 786 nil)
834 787
835 ;; Compile END statement. 788 ;; Compile END statement.
836 (defun ccl-compile-end (cmd) 789 (defun ccl-compile-end (cmd)
837 (if (/= (length cmd) 1) 790 (if (/= (length cmd) 1)
860 (ccl-check-register RRR cmd) 813 (ccl-check-register RRR cmd)
861 (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0)) 814 (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
862 nil) 815 nil)
863 816
864 ;; Compile translate-character 817 ;; Compile translate-character
865 ;; (defun ccl-compile-translate-character (cmd) 818 (defun ccl-compile-translate-character (cmd)
866 ;; (if (/= (length cmd) 4) 819 (if (/= (length cmd) 4)
867 ;; (error "CCL: Invalid number of arguments: %s" cmd)) 820 (error "CCL: Invalid number of arguments: %s" cmd))
868 ;; (let ((Rrr (nth 1 cmd)) 821 (let ((Rrr (nth 1 cmd))
869 ;; (RRR (nth 2 cmd)) 822 (RRR (nth 2 cmd))
870 ;; (rrr (nth 3 cmd))) 823 (rrr (nth 3 cmd)))
871 ;; (ccl-check-register rrr cmd) 824 (ccl-check-register rrr cmd)
872 ;; (ccl-check-register RRR cmd) 825 (ccl-check-register RRR cmd)
873 ;; (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number))) 826 (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
874 ;; (if (not (get Rrr 'translation-table)) 827 (ccl-embed-extended-command 'translate-character-const-tbl
875 ;; (error "CCL: Invalid translation table %s in %s" Rrr cmd)) 828 rrr RRR 0)
876 ;; (ccl-embed-extended-command 'translate-character-const-tbl 829 (ccl-embed-symbol Rrr 'translation-table-id))
877 ;; rrr RRR 0) 830 (t
878 ;; (ccl-embed-data Rrr)) 831 (ccl-check-register Rrr cmd)
879 ;; (t 832 (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
880 ;; (ccl-check-register Rrr cmd) 833 nil)
881 ;; (ccl-embed-extended-command 'translate-character rrr RRR Rrr)))) 834
882 ;; nil) 835 (defun ccl-compile-iterate-multiple-map (cmd)
883 836 (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
884 ;; (defun ccl-compile-iterate-multiple-map (cmd) 837 nil)
885 ;; (ccl-compile-multiple-map-function 'iterate-multiple-map cmd) 838
886 ;; nil) 839 (defun ccl-compile-map-multiple (cmd)
887 840 (if (/= (length cmd) 4)
888 ;; (defun ccl-compile-map-multiple (cmd) 841 (error "CCL: Invalid number of arguments: %s" cmd))
889 ;; (if (/= (length cmd) 4) 842 (let (func arg)
890 ;; (error "CCL: Invalid number of arguments: %s" cmd)) 843 (setq func
891 ;; (let ((func '(lambda (arg mp) 844 (lambda (arg mp)
892 ;; (let ((len 0) result add) 845 (let ((len 0) result add)
893 ;; (while arg 846 (while arg
894 ;; (if (consp (car arg)) 847 (if (consp (car arg))
895 ;; (setq add (funcall func (car arg) t) 848 (setq add (funcall func (car arg) t)
896 ;; result (append result add) 849 result (append result add)
897 ;; add (+ (-(car add)) 1)) 850 add (+ (- (car add)) 1))
898 ;; (setq result 851 (setq result
899 ;; (append result 852 (append result
900 ;; (list (car arg))) 853 (list (car arg)))
901 ;; add 1)) 854 add 1))
902 ;; (setq arg (cdr arg) 855 (setq arg (cdr arg)
903 ;; len (+ len add))) 856 len (+ len add)))
904 ;; (if mp 857 (if mp
905 ;; (cons (- len) result) 858 (cons (- len) result)
906 ;; result)))) 859 result))))
907 ;; arg) 860 (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
908 ;; (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd)) 861 (funcall func (nth 3 cmd) nil)))
909 ;; (funcall func (nth 3 cmd) nil))) 862 (ccl-compile-multiple-map-function 'map-multiple arg))
910 ;; (ccl-compile-multiple-map-function 'map-multiple arg)) 863 nil)
911 ;; nil) 864
912 865 (defun ccl-compile-map-single (cmd)
913 ;; (defun ccl-compile-map-single (cmd) 866 (if (/= (length cmd) 4)
914 ;; (if (/= (length cmd) 4) 867 (error "CCL: Invalid number of arguments: %s" cmd))
915 ;; (error "CCL: Invalid number of arguments: %s" cmd)) 868 (let ((RRR (nth 1 cmd))
916 ;; (let ((RRR (nth 1 cmd)) 869 (rrr (nth 2 cmd))
917 ;; (rrr (nth 2 cmd)) 870 (map (nth 3 cmd))
918 ;; (map (nth 3 cmd)) 871 id)
919 ;; id) 872 (ccl-check-register rrr cmd)
920 ;; (ccl-check-register rrr cmd) 873 (ccl-check-register RRR cmd)
921 ;; (ccl-check-register RRR cmd) 874 (ccl-embed-extended-command 'map-single rrr RRR 0)
922 ;; (ccl-embed-extended-command 'map-single rrr RRR 0) 875 (cond ((symbolp map)
923 ;; (cond ((symbolp map) 876 (if (get map 'code-conversion-map)
924 ;; (if (get map 'code-conversion-map) 877 (ccl-embed-symbol map 'code-conversion-map-id)
925 ;; (ccl-embed-data map) 878 (error "CCL: Invalid map: %s" map)))
926 ;; (error "CCL: Invalid map: %s" map))) 879 (t
927 ;; (t 880 (error "CCL: Invalid type of arguments: %s" cmd))))
928 ;; (error "CCL: Invalid type of arguments: %s" cmd)))) 881 nil)
929 ;; nil) 882
930 883 (defun ccl-compile-multiple-map-function (command cmd)
931 ;; (defun ccl-compile-multiple-map-function (command cmd) 884 (if (< (length cmd) 4)
932 ;; (if (< (length cmd) 4) 885 (error "CCL: Invalid number of arguments: %s" cmd))
933 ;; (error "CCL: Invalid number of arguments: %s" cmd)) 886 (let ((RRR (nth 1 cmd))
934 ;; (let ((RRR (nth 1 cmd)) 887 (rrr (nth 2 cmd))
935 ;; (rrr (nth 2 cmd)) 888 (args (nthcdr 3 cmd))
936 ;; (args (nthcdr 3 cmd)) 889 map)
937 ;; map) 890 (ccl-check-register rrr cmd)
938 ;; (ccl-check-register rrr cmd) 891 (ccl-check-register RRR cmd)
939 ;; (ccl-check-register RRR cmd) 892 (ccl-embed-extended-command command rrr RRR 0)
940 ;; (ccl-embed-extended-command command rrr RRR 0) 893 (ccl-embed-data (length args))
941 ;; (ccl-embed-data (length args)) 894 (while args
942 ;; (while args 895 (setq map (car args))
943 ;; (setq map (car args)) 896 (cond ((symbolp map)
944 ;; (cond ((symbolp map) 897 (if (get map 'code-conversion-map)
945 ;; (if (get map 'code-conversion-map) 898 (ccl-embed-symbol map 'code-conversion-map-id)
946 ;; (ccl-embed-data map) 899 (error "CCL: Invalid map: %s" map)))
947 ;; (error "CCL: Invalid map: %s" map))) 900 ((numberp map)
948 ;; ((numberp map) 901 (ccl-embed-data map))
949 ;; (ccl-embed-data map)) 902 (t
950 ;; (t 903 (error "CCL: Invalid type of arguments: %s" cmd)))
951 ;; (error "CCL: Invalid type of arguments: %s" cmd))) 904 (setq args (cdr args)))))
952 ;; (setq args (cdr args)))))
953 905
954 906
955 ;;; CCL dump stuff 907 ;;; CCL dump staffs
908
909 ;; To avoid byte-compiler warning.
910 (defvar ccl-code)
956 911
957 ;;;###autoload 912 ;;;###autoload
958 (defun ccl-dump (ccl-code) 913 (defun ccl-dump (ccl-code)
959 "Disassemble compiled CCL-CODE." 914 "Disassemble compiled CCL-CODE."
960 (let ((len (length ccl-code)) 915 (let ((len (length ccl-code))
978 (ccl-dump-1)) 933 (ccl-dump-1))
979 )) 934 ))
980 935
981 ;; Return a CCL code in `ccl-code' at `ccl-current-ic'. 936 ;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
982 (defun ccl-get-next-code () 937 (defun ccl-get-next-code ()
983 (declare (special ccl-code))
984 (prog1 938 (prog1
985 (aref ccl-code ccl-current-ic) 939 (aref ccl-code ccl-current-ic)
986 (setq ccl-current-ic (1+ ccl-current-ic)))) 940 (setq ccl-current-ic (1+ ccl-current-ic))))
987 941
988 (defun ccl-dump-1 () 942 (defun ccl-dump-1 ()
1228 (insert (format "read-multibyte-character r%d r%d\n" RRR rrr))) 1182 (insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
1229 1183
1230 (defun ccl-dump-write-multibyte-character (rrr RRR Rrr) 1184 (defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
1231 (insert (format "write-multibyte-character r%d r%d\n" RRR rrr))) 1185 (insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
1232 1186
1233 ;; (defun ccl-dump-translate-character (rrr RRR Rrr) 1187 (defun ccl-dump-translate-character (rrr RRR Rrr)
1234 ;; (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr))) 1188 (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
1235 1189
1236 ;; (defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr) 1190 (defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
1237 ;; (let ((tbl (ccl-get-next-code))) 1191 (let ((tbl (ccl-get-next-code)))
1238 ;; (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr)))) 1192 (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
1239 1193
1240 ;; (defun ccl-dump-iterate-multiple-map (rrr RRR Rrr) 1194 (defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
1241 ;; (let ((notbl (ccl-get-next-code)) 1195 (let ((notbl (ccl-get-next-code))
1242 ;; (i 0) id) 1196 (i 0) id)
1243 ;; (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr)) 1197 (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
1244 ;; (insert (format "\tnumber of maps is %d .\n\t [" notbl)) 1198 (insert (format "\tnumber of maps is %d .\n\t [" notbl))
1245 ;; (while (< i notbl) 1199 (while (< i notbl)
1246 ;; (setq id (ccl-get-next-code)) 1200 (setq id (ccl-get-next-code))
1247 ;; (insert (format "%S" id)) 1201 (insert (format "%S" id))
1248 ;; (setq i (1+ i))) 1202 (setq i (1+ i)))
1249 ;; (insert "]\n"))) 1203 (insert "]\n")))
1250 1204
1251 ;; (defun ccl-dump-map-multiple (rrr RRR Rrr) 1205 (defun ccl-dump-map-multiple (rrr RRR Rrr)
1252 ;; (let ((notbl (ccl-get-next-code)) 1206 (let ((notbl (ccl-get-next-code))
1253 ;; (i 0) id) 1207 (i 0) id)
1254 ;; (insert (format "map-multiple r%d r%d\n" RRR rrr)) 1208 (insert (format "map-multiple r%d r%d\n" RRR rrr))
1255 ;; (insert (format "\tnumber of maps and separators is %d\n\t [" notbl)) 1209 (insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
1256 ;; (while (< i notbl) 1210 (while (< i notbl)
1257 ;; (setq id (ccl-get-next-code)) 1211 (setq id (ccl-get-next-code))
1258 ;; (if (= id -1) 1212 (if (= id -1)
1259 ;; (insert "]\n\t [") 1213 (insert "]\n\t [")
1260 ;; (insert (format "%S " id))) 1214 (insert (format "%S " id)))
1261 ;; (setq i (1+ i))) 1215 (setq i (1+ i)))
1262 ;; (insert "]\n"))) 1216 (insert "]\n")))
1263 1217
1264 ;; (defun ccl-dump-map-single (rrr RRR Rrr) 1218 (defun ccl-dump-map-single (rrr RRR Rrr)
1265 ;; (let ((id (ccl-get-next-code))) 1219 (let ((id (ccl-get-next-code)))
1266 ;; (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id)))) 1220 (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
1267 1221
1268 1222
1269 ;; CCL emulation staffs 1223 ;; CCL emulation staffs
1270 1224
1271 ;; Not yet implemented. 1225 ;; Not yet implemented.
1274 1228
1275 ;;;###autoload 1229 ;;;###autoload
1276 (defmacro declare-ccl-program (name &optional vector) 1230 (defmacro declare-ccl-program (name &optional vector)
1277 "Declare NAME as a name of CCL program. 1231 "Declare NAME as a name of CCL program.
1278 1232
1279 To compile a CCL program which calls another CCL program not yet 1233 This macro exists for backward compatibility. In the old version of
1280 defined, it must be declared as a CCL program in advance. 1234 Emacs, to compile a CCL program which calls another CCL program not
1235 yet defined, it must be declared as a CCL program in advance. But,
1236 now CCL program names are resolved not at compile time but before
1237 execution.
1238
1281 Optional arg VECTOR is a compiled CCL code of the CCL program." 1239 Optional arg VECTOR is a compiled CCL code of the CCL program."
1282 `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector))) 1240 `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
1283 1241
1284 ;;;###autoload 1242 ;;;###autoload
1285 (defmacro define-ccl-program (name ccl-program &optional doc) 1243 (defmacro define-ccl-program (name ccl-program &optional doc)
1286 "Set NAME the compiled code of CCL-PROGRAM. 1244 "Set NAME the compiled code of CCL-PROGRAM.
1287 CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'. 1245
1288 The compiled code is a vector of integers." 1246 CCL-PROGRAM has this form:
1247 (BUFFER_MAGNIFICATION
1248 CCL_MAIN_CODE
1249 [ CCL_EOF_CODE ])
1250
1251 BUFFER_MAGNIFICATION is an integer value specifying the approximate
1252 output buffer magnification size compared with the bytes of input data
1253 text. If the value is zero, the CCL program can't execute `read' and
1254 `write' commands.
1255
1256 CCL_MAIN_CODE and CCL_EOF_CODE are CCL program codes. CCL_MAIN_CODE
1257 executed at first. If there's no more input data when `read' command
1258 is executed in CCL_MAIN_CODE, CCL_EOF_CODE is executed. If
1259 CCL_MAIN_CODE is terminated, CCL_EOF_CODE is not executed.
1260
1261 Here's the syntax of CCL program code in BNF notation. The lines
1262 starting by two semicolons (and optional leading spaces) describe the
1263 semantics.
1264
1265 CCL_MAIN_CODE := CCL_BLOCK
1266
1267 CCL_EOF_CODE := CCL_BLOCK
1268
1269 CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...])
1270
1271 STATEMENT :=
1272 SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
1273 | TRANSLATE | END
1274
1275 SET := (REG = EXPRESSION)
1276 | (REG ASSIGNMENT_OPERATOR EXPRESSION)
1277 ;; The following form is the same as (r0 = integer).
1278 | integer
1279
1280 EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
1281
1282 ;; Evaluate EXPRESSION. If the result is nonzeor, execute
1283 ;; CCL_BLOCK_0. Otherwise, execute CCL_BLOCK_1.
1284 IF := (if EXPRESSION CCL_BLOCK_0 CCL_BLOCK_1)
1285
1286 ;; Evaluate EXPRESSION. Provided that the result is N, execute
1287 ;; CCL_BLOCK_N.
1288 BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...])
1289
1290 ;; Execute STATEMENTs until (break) or (end) is executed.
1291 LOOP := (loop STATEMENT [STATEMENT ...])
1292
1293 ;; Terminate the most inner loop.
1294 BREAK := (break)
1295
1296 REPEAT :=
1297 ;; Jump to the head of the most inner loop.
1298 (repeat)
1299 ;; Same as: ((write [REG | integer | string])
1300 ;; (repeat))
1301 | (write-repeat [REG | integer | string])
1302 ;; Same as: ((write REG [ARRAY])
1303 ;; (read REG)
1304 ;; (repeat))
1305 | (write-read-repeat REG [ARRAY])
1306 ;; Same as: ((write integer)
1307 ;; (read REG)
1308 ;; (repeat))
1309 | (write-read-repeat REG integer)
1310
1311 READ := ;; Set REG_0 to a byte read from the input text, set REG_1
1312 ;; to the next byte read, and so on.
1313 (read REG_0 [REG_1 ...])
1314 ;; Same as: ((read REG)
1315 ;; (if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1))
1316 | (read-if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1)
1317 ;; Same as: ((read REG)
1318 ;; (branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...]))
1319 | (read-branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...])
1320 ;; Read a character from the input text while parsing
1321 ;; multibyte representation, set REG_0 to the charset ID of
1322 ;; the character, set REG_1 to the code point of the
1323 ;; character. If the dimension of charset is two, set REG_1
1324 ;; to ((CODE0 << 8) | CODE1), where CODE0 is the first code
1325 ;; point and CODE1 is the second code point.
1326 | (read-multibyte-character REG_0 REG_1)
1327
1328 WRITE :=
1329 ;; Write REG_0, REG_1, ... to the output buffer. If REG_N is
1330 ;; a multibyte character, write the corresponding multibyte
1331 ;; representation.
1332 (write REG_0 [REG_1 ...])
1333 ;; Same as: ((r7 = EXPRESSION)
1334 ;; (write r7))
1335 | (write EXPRESSION)
1336 ;; Write the value of `integer' to the output buffer. If it
1337 ;; is a multibyte character, write the corresponding multibyte
1338 ;; representation.
1339 | (write integer)
1340 ;; Write the byte sequence of `string' as is to the output
1341 ;; buffer. It is encoded by binary coding system, thus,
1342 ;; by this operation, you cannot write multibyte string
1343 ;; as it is.
1344 | (write string)
1345 ;; Same as: (write string)
1346 | string
1347 ;; Provided that the value of REG is N, write Nth element of
1348 ;; ARRAY to the output buffer. If it is a multibyte
1349 ;; character, write the corresponding multibyte
1350 ;; representation.
1351 | (write REG ARRAY)
1352 ;; Write a multibyte representation of a character whose
1353 ;; charset ID is REG_0 and code point is REG_1. If the
1354 ;; dimension of the charset is two, REG_1 should be ((CODE0 <<
1355 ;; 8) | CODE1), where CODE0 is the first code point and CODE1
1356 ;; is the second code point of the character.
1357 | (write-multibyte-character REG_0 REG_1)
1358
1359 ;; Call CCL program whose name is ccl-program-name.
1360 CALL := (call ccl-program-name)
1361
1362 ;; Terminate the CCL program.
1363 END := (end)
1364
1365 ;; CCL registers that can contain any integer value. As r7 is also
1366 ;; used by CCL interpreter, its value is changed unexpectedly.
1367 REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
1368
1369 ARG := REG | integer
1370
1371 OPERATOR :=
1372 ;; Normal arithmethic operators (same meaning as C code).
1373 + | - | * | / | %
1374
1375 ;; Bitwize operators (same meaning as C code)
1376 | & | `|' | ^
1377
1378 ;; Shifting operators (same meaning as C code)
1379 | << | >>
1380
1381 ;; (REG = ARG_0 <8 ARG_1) means:
1382 ;; (REG = ((ARG_0 << 8) | ARG_1))
1383 | <8
1384
1385 ;; (REG = ARG_0 >8 ARG_1) means:
1386 ;; ((REG = (ARG_0 >> 8))
1387 ;; (r7 = (ARG_0 & 255)))
1388 | >8
1389
1390 ;; (REG = ARG_0 // ARG_1) means:
1391 ;; ((REG = (ARG_0 / ARG_1))
1392 ;; (r7 = (ARG_0 % ARG_1)))
1393 | //
1394
1395 ;; Normal comparing operators (same meaning as C code)
1396 | < | > | == | <= | >= | !=
1397
1398 ;; If ARG_0 and ARG_1 are higher and lower byte of Shift-JIS
1399 ;; code, and CHAR is the corresponding JISX0208 character,
1400 ;; (REG = ARG_0 de-sjis ARG_1) means:
1401 ;; ((REG = CODE0)
1402 ;; (r7 = CODE1))
1403 ;; where CODE0 is the first code point of CHAR, CODE1 is the
1404 ;; second code point of CHAR.
1405 | de-sjis
1406
1407 ;; If ARG_0 and ARG_1 are the first and second code point of
1408 ;; JISX0208 character CHAR, and SJIS is the correponding
1409 ;; Shift-JIS code,
1410 ;; (REG = ARG_0 en-sjis ARG_1) means:
1411 ;; ((REG = HIGH)
1412 ;; (r7 = LOW))
1413 ;; where HIGH is the higher byte of SJIS, LOW is the lower
1414 ;; byte of SJIS.
1415 | en-sjis
1416
1417 ASSIGNMENT_OPERATOR :=
1418 ;; Same meaning as C code
1419 += | -= | *= | /= | %= | &= | `|=' | ^= | <<= | >>=
1420
1421 ;; (REG <8= ARG) is the same as:
1422 ;; ((REG <<= 8)
1423 ;; (REG |= ARG))
1424 | <8=
1425
1426 ;; (REG >8= ARG) is the same as:
1427 ;; ((r7 = (REG & 255))
1428 ;; (REG >>= 8))
1429
1430 ;; (REG //= ARG) is the same as:
1431 ;; ((r7 = (REG % ARG))
1432 ;; (REG /= ARG))
1433 | //=
1434
1435 ARRAY := `[' integer ... `]'
1436
1437
1438 TRANSLATE :=
1439 (translate-character REG(table) REG(charset) REG(codepoint))
1440 | (translate-character SYMBOL REG(charset) REG(codepoint))
1441 MAP :=
1442 (iterate-multiple-map REG REG MAP-IDs)
1443 | (map-multiple REG REG (MAP-SET))
1444 | (map-single REG REG MAP-ID)
1445 MAP-IDs := MAP-ID ...
1446 MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET
1447 MAP-ID := integer
1448 "
1289 `(let ((prog ,(ccl-compile (eval ccl-program)))) 1449 `(let ((prog ,(ccl-compile (eval ccl-program))))
1290 (defconst ,name prog ,doc) 1450 (defconst ,name prog ,doc)
1291 (put ',name 'ccl-program-idx (register-ccl-program ',name prog)) 1451 (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
1292 nil)) 1452 nil))
1293 1453
1294 ;;;###autoload 1454 ;;;###autoload
1295 (defmacro check-ccl-program (ccl-program &optional name) 1455 (defmacro check-ccl-program (ccl-program &optional name)
1296 "Check validity of CCL-PROGRAM. 1456 "Check validity of CCL-PROGRAM.
1297 If CCL-PROGRAM is a symbol denoting a valid CCL program, return 1457 If CCL-PROGRAM is a symbol denoting a CCL program, return
1298 CCL-PROGRAM, else return nil. 1458 CCL-PROGRAM, else return nil.
1299 If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied, 1459 If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
1300 register CCL-PROGRAM by name NAME, and return NAME." 1460 register CCL-PROGRAM by name NAME, and return NAME."
1301 `(let ((result ,ccl-program)) 1461 `(if (ccl-program-p ,ccl-program)
1302 (cond ((symbolp ,ccl-program) 1462 (if (vectorp ,ccl-program)
1303 (or (numberp (get ,ccl-program 'ccl-program-idx)) 1463 (progn
1304 (setq result nil))) 1464 (register-ccl-program ,name ,ccl-program)
1305 ((vectorp ,ccl-program) 1465 ,name)
1306 (setq result ,name) 1466 ,ccl-program)))
1307 (register-ccl-program result ,ccl-program))
1308 (t
1309 (setq result nil)))
1310 result))
1311 1467
1312 ;;;###autoload 1468 ;;;###autoload
1313 (defun ccl-execute-with-args (ccl-prog &rest args) 1469 (defun ccl-execute-with-args (ccl-prog &rest args)
1314 "Execute CCL-PROGRAM with registers initialized by the remaining args. 1470 "Execute CCL-PROGRAM with registers initialized by the remaining args.
1315 The return value is a vector of resulting CCL registers." 1471 The return value is a vector of resulting CCL registers.
1472
1473 See the documentation of `define-ccl-program' for the detail of CCL program."
1316 (let ((reg (make-vector 8 0)) 1474 (let ((reg (make-vector 8 0))
1317 (i 0)) 1475 (i 0))
1318 (while (and args (< i 8)) 1476 (while (and args (< i 8))
1319 (if (not (integerp (car args))) 1477 (if (not (integerp (car args)))
1320 (error "Arguments should be integer")) 1478 (error "Arguments should be integer"))