2 |
|
|
3 |
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. |
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. |
4 |
;; Licensed to the Free Software Foundation. |
;; Licensed to the Free Software Foundation. |
5 |
|
;; Copyright (C) 2002 Free Software Foundation, Inc. |
6 |
|
|
7 |
;; Keywords: CCL, mule, multilingual, character set, coding-system |
;; Keywords: CCL, mule, multilingual, character set, coding-system |
8 |
|
|
26 |
;;; Commentary: |
;;; Commentary: |
27 |
|
|
28 |
;; CCL (Code Conversion Language) is a simple programming language to |
;; CCL (Code Conversion Language) is a simple programming language to |
29 |
;; be used for various kind of code conversion. CCL program is |
;; be used for various kind of code conversion. A CCL program is |
30 |
;; compiled to CCL code (vector of integers) and executed by CCL |
;; compiled to CCL code (vector of integers) and executed by the CCL |
31 |
;; interpreter of Emacs. |
;; interpreter in Emacs. |
32 |
;; |
;; |
33 |
;; CCL is used for code conversion at process I/O and file I/O for |
;; CCL is used for code conversion at process I/O and file I/O for |
34 |
;; non-standard coding-system. In addition, it is used for |
;; non-standard coding-systems. In addition, it is used for |
35 |
;; calculating a code point of X's font from a character code. |
;; calculating code points of X fonts from character codes. |
36 |
;; However, since CCL is designed as a powerful programming language, |
;; However, since CCL is designed as a powerful programming language, |
37 |
;; it can be used for more generic calculation. For instance, |
;; it can be used for more generic calculation. For instance, |
38 |
;; combination of three or more arithmetic operations can be |
;; combination of three or more arithmetic operations can be |
39 |
;; calculated faster than Emacs Lisp. |
;; calculated faster than in Emacs Lisp. |
40 |
;; |
;; |
41 |
;; Syntax and semantics of CCL program is described in the |
;; The syntax and semantics of CCL programs are described in the |
42 |
;; documentation of `define-ccl-program'. |
;; documentation of `define-ccl-program'. |
43 |
|
|
44 |
;;; Code: |
;;; Code: |
53 |
read read-if read-branch write call end |
read read-if read-branch write call end |
54 |
read-multibyte-character write-multibyte-character |
read-multibyte-character write-multibyte-character |
55 |
translate-character |
translate-character |
56 |
iterate-multiple-map map-multiple map-single] |
iterate-multiple-map map-multiple map-single lookup-integer |
57 |
|
lookup-character] |
58 |
"Vector of CCL commands (symbols).") |
"Vector of CCL commands (symbols).") |
59 |
|
|
60 |
;; Put a property to each symbol of CCL commands for the compiler. |
;; Put a property to each symbol of CCL commands for the compiler. |
109 |
iterate-multiple-map |
iterate-multiple-map |
110 |
map-multiple |
map-multiple |
111 |
map-single |
map-single |
112 |
|
lookup-int-const-tbl |
113 |
|
lookup-char-const-tbl |
114 |
] |
] |
115 |
"Vector of CCL extended compiled codes (symbols).") |
"Vector of CCL extended compiled codes (symbols).") |
116 |
|
|
200 |
|
|
201 |
;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give |
;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give |
202 |
;; proper index number for SYMBOL. PROP should be |
;; proper index number for SYMBOL. PROP should be |
203 |
;; `translation-table-id', `code-conversion-map-id', or |
;; `translation-table-id', `translation-hash-table-id' |
204 |
;; `ccl-program-idx'. |
;; `code-conversion-map-id', or `ccl-program-idx'. |
205 |
(defun ccl-embed-symbol (symbol prop) |
(defun ccl-embed-symbol (symbol prop) |
206 |
(ccl-embed-data (cons symbol prop))) |
(ccl-embed-data (cons symbol prop))) |
207 |
|
|
237 |
|
|
238 |
;; If REG is a CCL register symbol (e.g. r0, r1...), the register |
;; If REG is a CCL register symbol (e.g. r0, r1...), the register |
239 |
;; number is embedded. If OP is one of unconditional jumps, DATA is |
;; number is embedded. If OP is one of unconditional jumps, DATA is |
240 |
;; changed to an relative jump address. |
;; changed to a relative jump address. |
241 |
|
|
242 |
(defun ccl-embed-code (op reg data &optional reg2) |
(defun ccl-embed-code (op reg data &optional reg2) |
243 |
(if (and (> data 0) (get op 'jump-flag)) |
(if (and (> data 0) (get op 'jump-flag)) |
509 |
(ccl-embed-data op) |
(ccl-embed-data op) |
510 |
(ccl-embed-data arg)) |
(ccl-embed-data arg)) |
511 |
(ccl-check-register arg cmd) |
(ccl-check-register arg cmd) |
512 |
(ccl-embed-code (if read-flag 'read-jump-cond-expr-register |
(ccl-embed-code (if read-flag 'read-jump-cond-expr-register |
513 |
'jump-cond-expr-register) |
'jump-cond-expr-register) |
514 |
rrr 0) |
rrr 0) |
515 |
(ccl-embed-data op) |
(ccl-embed-data op) |
707 |
(error "CCL: Invalid argument %s: %s" arg cmd))) |
(error "CCL: Invalid argument %s: %s" arg cmd))) |
708 |
(ccl-embed-code 'read-jump rrr ccl-loop-head)) |
(ccl-embed-code 'read-jump rrr ccl-loop-head)) |
709 |
t) |
t) |
710 |
|
|
711 |
;; Compile READ statement. |
;; Compile READ statement. |
712 |
(defun ccl-compile-read (cmd) |
(defun ccl-compile-read (cmd) |
713 |
(if (< (length cmd) 2) |
(if (< (length cmd) 2) |
837 |
(ccl-embed-extended-command 'translate-character rrr RRR Rrr)))) |
(ccl-embed-extended-command 'translate-character rrr RRR Rrr)))) |
838 |
nil) |
nil) |
839 |
|
|
840 |
|
;; Compile lookup-integer |
841 |
|
(defun ccl-compile-lookup-integer (cmd) |
842 |
|
(if (/= (length cmd) 4) |
843 |
|
(error "CCL: Invalid number of arguments: %s" cmd)) |
844 |
|
(let ((Rrr (nth 1 cmd)) |
845 |
|
(RRR (nth 2 cmd)) |
846 |
|
(rrr (nth 3 cmd))) |
847 |
|
(ccl-check-register RRR cmd) |
848 |
|
(ccl-check-register rrr cmd) |
849 |
|
(cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number))) |
850 |
|
(ccl-embed-extended-command 'lookup-int-const-tbl |
851 |
|
rrr RRR 0) |
852 |
|
(ccl-embed-symbol Rrr 'translation-hash-table-id)) |
853 |
|
(t |
854 |
|
(error "CCL: non-constant table: %s" cmd) |
855 |
|
;; not implemented: |
856 |
|
(ccl-check-register Rrr cmd) |
857 |
|
(ccl-embed-extended-command 'lookup-int rrr RRR 0)))) |
858 |
|
nil) |
859 |
|
|
860 |
|
;; Compile lookup-character |
861 |
|
(defun ccl-compile-lookup-character (cmd) |
862 |
|
(if (/= (length cmd) 4) |
863 |
|
(error "CCL: Invalid number of arguments: %s" cmd)) |
864 |
|
(let ((Rrr (nth 1 cmd)) |
865 |
|
(RRR (nth 2 cmd)) |
866 |
|
(rrr (nth 3 cmd))) |
867 |
|
(ccl-check-register RRR cmd) |
868 |
|
(ccl-check-register rrr cmd) |
869 |
|
(cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number))) |
870 |
|
(ccl-embed-extended-command 'lookup-char-const-tbl |
871 |
|
rrr RRR 0) |
872 |
|
(ccl-embed-symbol Rrr 'translation-hash-table-id)) |
873 |
|
(t |
874 |
|
(error "CCL: non-constant table: %s" cmd) |
875 |
|
;; not implemented: |
876 |
|
(ccl-check-register Rrr cmd) |
877 |
|
(ccl-embed-extended-command 'lookup-char rrr RRR 0)))) |
878 |
|
nil) |
879 |
|
|
880 |
(defun ccl-compile-iterate-multiple-map (cmd) |
(defun ccl-compile-iterate-multiple-map (cmd) |
881 |
(ccl-compile-multiple-map-function 'iterate-multiple-map cmd) |
(ccl-compile-multiple-map-function 'iterate-multiple-map cmd) |
882 |
nil) |
nil) |
899 |
add 1)) |
add 1)) |
900 |
(setq arg (cdr arg) |
(setq arg (cdr arg) |
901 |
len (+ len add))) |
len (+ len add))) |
902 |
(if mp |
(if mp |
903 |
(cons (- len) result) |
(cons (- len) result) |
904 |
result)))) |
result)))) |
905 |
(setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd)) |
(setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd)) |
949 |
(setq args (cdr args))))) |
(setq args (cdr args))))) |
950 |
|
|
951 |
|
|
952 |
;;; CCL dump staffs |
;;; CCL dump stuff |
953 |
|
|
954 |
;; To avoid byte-compiler warning. |
;; To avoid byte-compiler warning. |
955 |
(defvar ccl-code) |
(defvar ccl-code) |
990 |
(rrr (ash (logand code 255) -5)) |
(rrr (ash (logand code 255) -5)) |
991 |
(cc (ash code -8))) |
(cc (ash code -8))) |
992 |
(insert (format "%5d:[%s] " (1- ccl-current-ic) cmd)) |
(insert (format "%5d:[%s] " (1- ccl-current-ic) cmd)) |
993 |
(funcall (get cmd 'ccl-dump-function) rrr cc))) |
(funcall (get cmd 'ccl-dump-function) rrr cc))) |
994 |
|
|
995 |
(defun ccl-dump-set-register (rrr cc) |
(defun ccl-dump-set-register (rrr cc) |
996 |
(insert (format "r%d = r%d\n" rrr cc))) |
(insert (format "r%d = r%d\n" rrr cc))) |
1236 |
(let ((tbl (ccl-get-next-code))) |
(let ((tbl (ccl-get-next-code))) |
1237 |
(insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr)))) |
(insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr)))) |
1238 |
|
|
1239 |
|
(defun ccl-dump-lookup-int-const-tbl (rrr RRR Rrr) |
1240 |
|
(let ((tbl (ccl-get-next-code))) |
1241 |
|
(insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr)))) |
1242 |
|
|
1243 |
|
(defun ccl-dump-lookup-char-const-tbl (rrr RRR Rrr) |
1244 |
|
(let ((tbl (ccl-get-next-code))) |
1245 |
|
(insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr)))) |
1246 |
|
|
1247 |
(defun ccl-dump-iterate-multiple-map (rrr RRR Rrr) |
(defun ccl-dump-iterate-multiple-map (rrr RRR Rrr) |
1248 |
(let ((notbl (ccl-get-next-code)) |
(let ((notbl (ccl-get-next-code)) |
1249 |
(i 0) id) |
(i 0) id) |
1273 |
(insert (format "map-single r%d r%d map(%S)\n" RRR rrr id)))) |
(insert (format "map-single r%d r%d map(%S)\n" RRR rrr id)))) |
1274 |
|
|
1275 |
|
|
1276 |
;; CCL emulation staffs |
;; CCL emulation staffs |
1277 |
|
|
1278 |
;; Not yet implemented. |
;; Not yet implemented. |
1279 |
|
|
1323 |
|
|
1324 |
STATEMENT := |
STATEMENT := |
1325 |
SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL |
SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL |
1326 |
| TRANSLATE | END |
| TRANSLATE | MAP | LOOKUP | END |
1327 |
|
|
1328 |
SET := (REG = EXPRESSION) |
SET := (REG = EXPRESSION) |
1329 |
| (REG ASSIGNMENT_OPERATOR EXPRESSION) |
| (REG ASSIGNMENT_OPERATOR EXPRESSION) |
1472 |
;; (REG <8= ARG) is the same as: |
;; (REG <8= ARG) is the same as: |
1473 |
;; ((REG <<= 8) |
;; ((REG <<= 8) |
1474 |
;; (REG |= ARG)) |
;; (REG |= ARG)) |
1475 |
| <8= |
| <8= |
1476 |
|
|
1477 |
;; (REG >8= ARG) is the same as: |
;; (REG >8= ARG) is the same as: |
1478 |
;; ((r7 = (REG & 255)) |
;; ((r7 = (REG & 255)) |
1490 |
(translate-character REG(table) REG(charset) REG(codepoint)) |
(translate-character REG(table) REG(charset) REG(codepoint)) |
1491 |
| (translate-character SYMBOL REG(charset) REG(codepoint)) |
| (translate-character SYMBOL REG(charset) REG(codepoint)) |
1492 |
;; SYMBOL must refer to a table defined by `define-translation-table'. |
;; SYMBOL must refer to a table defined by `define-translation-table'. |
1493 |
|
LOOKUP := |
1494 |
|
(lookup-character SYMBOL REG(charset) REG(codepoint)) |
1495 |
|
| (lookup-integer SYMBOL REG(integer)) |
1496 |
|
;; SYMBOL refers to a table defined by `define-hash-translation-table'. |
1497 |
MAP := |
MAP := |
1498 |
(iterate-multiple-map REG REG MAP-IDs) |
(iterate-multiple-map REG REG MAP-IDs) |
1499 |
| (map-multiple REG REG (MAP-SET)) |
| (map-multiple REG REG (MAP-SET)) |