Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-ccl.el @ 422:95016f13131a r21-2-19

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-19
author cvs
date Mon, 13 Aug 2007 11:25:01 +0200
parents 697ef44129c6
children
comparison
equal deleted inserted replaced
421:fff06e11db74 422:95016f13131a
72 ;; | (write-read-repeat REG [integer | ARRAY]) 72 ;; | (write-read-repeat REG [integer | ARRAY])
73 ;; READ := 73 ;; READ :=
74 ;; (read REG ...) 74 ;; (read REG ...)
75 ;; | (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK) 75 ;; | (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK)
76 ;; | (read-branch REG CCL_BLOCK [CCL_BLOCK ...]) 76 ;; | (read-branch REG CCL_BLOCK [CCL_BLOCK ...])
77 ;; | (read-multibyte-character REG {charset} REG {code-point})
77 ;; WRITE := 78 ;; WRITE :=
78 ;; (write REG ...) 79 ;; (write REG ...)
79 ;; | (write EXPRESSION) 80 ;; | (write EXPRESSION)
80 ;; | (write integer) | (write string) | (write REG ARRAY) 81 ;; | (write integer) | (write string) | (write REG ARRAY)
81 ;; | string 82 ;; | string
83 ;; | (write-multibyte-character REG(charset) REG(codepoint))
82 ;; CALL := (call ccl-program-name) 84 ;; CALL := (call ccl-program-name)
83 ;; END := (end) 85 ;; END := (end)
84 ;; 86 ;;
85 ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 87 ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
86 ;; ARG := REG | integer 88 ;; ARG := REG | integer
87 ;; OPERATOR := 89 ;; OPERATOR :=
88 ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // 90 ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
89 ;; | < | > | == | <= | >= | != | de-sjis | en-sjis 91 ;; | < | > | == | <= | >= | != | de-sjis | en-sjis
90 ;; ASSIGNMENT_OPERATOR := 92 ;; ASSIGNMENT_OPERATOR :=
91 ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= 93 ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
92 ;; ARRAY := '[' interger ... ']' 94 ;; ARRAY := '[' integer ... ']'
93 95
94 ;;; Code: 96 ;;; Code:
95 97
96 (defconst ccl-command-table 98 (defconst ccl-command-table
97 [if branch loop break repeat write-repeat write-read-repeat 99 [if branch loop break repeat write-repeat write-read-repeat
98 read read-if read-branch write call end] 100 read read-if read-branch write call end
99 "*Vector of CCL commands (symbols).") 101 read-multibyte-character write-multibyte-character]
102 "Vector of CCL commands (symbols).")
100 103
101 ;; Put a property to each symbol of CCL commands for the compiler. 104 ;; Put a property to each symbol of CCL commands for the compiler.
102 (let (op (i 0) (len (length ccl-command-table))) 105 (let (op (i 0) (len (length ccl-command-table)))
103 (while (< i len) 106 (while (< i len)
104 (setq op (aref ccl-command-table i)) 107 (setq op (aref ccl-command-table i))
135 set-expr-register 138 set-expr-register
136 jump-cond-expr-const 139 jump-cond-expr-const
137 jump-cond-expr-register 140 jump-cond-expr-register
138 read-jump-cond-expr-const 141 read-jump-cond-expr-const
139 read-jump-cond-expr-register 142 read-jump-cond-expr-register
143 ex-cmd
140 ] 144 ]
141 "*Vector of CCL compiled codes (symbols).") 145 "Vector of CCL compiled codes (symbols).")
146
147 (defconst ccl-extended-code-table
148 [read-multibyte-character
149 write-multibyte-character
150 translate-character
151 translate-character-const-tbl
152 nil nil nil nil nil nil nil nil nil nil nil nil ; 0x04-0x0f
153 iterate-multiple-map
154 map-multiple
155 map-single
156 ]
157 "Vector of CCL extended compiled codes (symbols).")
142 158
143 ;; Put a property to each symbol of CCL codes for the disassembler. 159 ;; Put a property to each symbol of CCL codes for the disassembler.
144 (let (code (i 0) (len (length ccl-code-table))) 160 (let (code (i 0) (len (length ccl-code-table)))
145 (while (< i len) 161 (while (< i len)
146 (setq code (aref ccl-code-table i)) 162 (setq code (aref ccl-code-table i))
147 (put code 'ccl-code i) 163 (put code 'ccl-code i)
148 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code))) 164 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
149 (setq i (1+ i)))) 165 (setq i (1+ i))))
150 166
167 (let (code (i 0) (len (length ccl-extended-code-table)))
168 (while (< i len)
169 (setq code (aref ccl-extended-code-table i))
170 (if code
171 (progn
172 (put code 'ccl-ex-code i)
173 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))))
174 (setq i (1+ i))))
175
151 (defconst ccl-jump-code-list 176 (defconst ccl-jump-code-list
152 '(jump jump-cond write-register-jump write-register-read-jump 177 '(jump jump-cond write-register-jump write-register-read-jump
153 write-const-jump write-const-read-jump write-string-jump 178 write-const-jump write-const-read-jump write-string-jump
154 write-array-read-jump read-jump)) 179 write-array-read-jump read-jump))
155 180
160 (put (car l) 'jump-flag t) 185 (put (car l) 'jump-flag t)
161 (setq l (cdr l)))) 186 (setq l (cdr l))))
162 187
163 (defconst ccl-register-table 188 (defconst ccl-register-table
164 [r0 r1 r2 r3 r4 r5 r6 r7] 189 [r0 r1 r2 r3 r4 r5 r6 r7]
165 "*Vector of CCL registers (symbols).") 190 "Vector of CCL registers (symbols).")
166 191
167 ;; Put a property to indicate register number to each symbol of CCL. 192 ;; Put a property to indicate register number to each symbol of CCL.
168 ;; registers. 193 ;; registers.
169 (let (reg (i 0) (len (length ccl-register-table))) 194 (let (reg (i 0) (len (length ccl-register-table)))
170 (while (< i len) 195 (while (< i len)
173 (setq i (1+ i)))) 198 (setq i (1+ i))))
174 199
175 (defconst ccl-arith-table 200 (defconst ccl-arith-table
176 [+ - * / % & | ^ << >> <8 >8 // nil nil nil 201 [+ - * / % & | ^ << >> <8 >8 // nil nil nil
177 < > == <= >= != de-sjis en-sjis] 202 < > == <= >= != de-sjis en-sjis]
178 "*Vector of CCL arithmetic/logical operators (symbols).") 203 "Vector of CCL arithmetic/logical operators (symbols).")
179 204
180 ;; Put a property to each symbol of CCL operators for the compiler. 205 ;; Put a property to each symbol of CCL operators for the compiler.
181 (let (arith (i 0) (len (length ccl-arith-table))) 206 (let (arith (i 0) (len (length ccl-arith-table)))
182 (while (< i len) 207 (while (< i len)
183 (setq arith (aref ccl-arith-table i)) 208 (setq arith (aref ccl-arith-table i))
184 (if arith (put arith 'ccl-arith-code i)) 209 (if arith (put arith 'ccl-arith-code i))
185 (setq i (1+ i)))) 210 (setq i (1+ i))))
186 211
187 (defconst ccl-assign-arith-table 212 (defconst ccl-assign-arith-table
188 [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=] 213 [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
189 "*Vector of CCL assignment operators (symbols).") 214 "Vector of CCL assignment operators (symbols).")
190 215
191 ;; Put a property to each symbol of CCL assignment operators for the compiler. 216 ;; Put a property to each symbol of CCL assignment operators for the compiler.
192 (let (arith (i 0) (len (length ccl-assign-arith-table))) 217 (let (arith (i 0) (len (length ccl-assign-arith-table)))
193 (while (< i len) 218 (while (< i len)
194 (setq arith (aref ccl-assign-arith-table i)) 219 (setq arith (aref ccl-assign-arith-table i))
255 (logior (ash (get reg2 'ccl-register-number) 8) 280 (logior (ash (get reg2 'ccl-register-number) 8)
256 (ash data 11)) 281 (ash data 11))
257 (ash data 8))))) 282 (ash data 8)))))
258 (aset ccl-program-vector ccl-current-ic code) 283 (aset ccl-program-vector ccl-current-ic code)
259 (setq ccl-current-ic (1+ ccl-current-ic)))) 284 (setq ccl-current-ic (1+ ccl-current-ic))))
285
286 ;; extended ccl command format
287 ;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
288 ;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|
289 (defun ccl-embed-extended-command (ex-op reg reg2 reg3)
290 (let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
291 (if (symbolp reg3)
292 (get reg3 'ccl-register-number)
293 0))))
294 (ccl-embed-code 'ex-cmd reg data reg2)))
260 295
261 ;; Just advance `ccl-current-ic' by INC. 296 ;; Just advance `ccl-current-ic' by INC.
262 (defun ccl-increment-ic (inc) 297 (defun ccl-increment-ic (inc)
263 (setq ccl-current-ic (+ ccl-current-ic inc))) 298 (setq ccl-current-ic (+ ccl-current-ic inc)))
264 299
522 557
523 ;; Compile TRUE-PART. 558 ;; Compile TRUE-PART.
524 (let ((unconditional-jump (ccl-compile-1 true-cmds))) 559 (let ((unconditional-jump (ccl-compile-1 true-cmds)))
525 (if (null false-cmds) 560 (if (null false-cmds)
526 ;; This is the place to jump to if condition is false. 561 ;; This is the place to jump to if condition is false.
527 (ccl-embed-current-address jump-cond-address) 562 (progn
563 (ccl-embed-current-address jump-cond-address)
564 (setq unconditional-jump nil))
528 (let (end-true-part-address) 565 (let (end-true-part-address)
529 (if (not unconditional-jump) 566 (if (not unconditional-jump)
530 (progn 567 (progn
531 ;; If TRUE-PART does not end with unconditional jump, we 568 ;; If TRUE-PART does not end with unconditional jump, we
532 ;; have to jump to the end of FALSE-PART from here. 569 ;; have to jump to the end of FALSE-PART from here.
800 (if (/= (length cmd) 1) 837 (if (/= (length cmd) 1)
801 (error "CCL: Invalid number of arguments: %s" cmd)) 838 (error "CCL: Invalid number of arguments: %s" cmd))
802 (ccl-embed-code 'end 0 0) 839 (ccl-embed-code 'end 0 0)
803 t) 840 t)
804 841
842 ;; Compile read-multibyte-character
843 (defun ccl-compile-read-multibyte-character (cmd)
844 (if (/= (length cmd) 3)
845 (error "CCL: Invalid number of arguments: %s" cmd))
846 (let ((RRR (nth 1 cmd))
847 (rrr (nth 2 cmd)))
848 (ccl-check-register rrr cmd)
849 (ccl-check-register RRR cmd)
850 (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
851 nil)
852
853 ;; Compile write-multibyte-character
854 (defun ccl-compile-write-multibyte-character (cmd)
855 (if (/= (length cmd) 3)
856 (error "CCL: Invalid number of arguments: %s" cmd))
857 (let ((RRR (nth 1 cmd))
858 (rrr (nth 2 cmd)))
859 (ccl-check-register rrr cmd)
860 (ccl-check-register RRR cmd)
861 (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
862 nil)
863
864 ;; Compile translate-character
865 ;; (defun ccl-compile-translate-character (cmd)
866 ;; (if (/= (length cmd) 4)
867 ;; (error "CCL: Invalid number of arguments: %s" cmd))
868 ;; (let ((Rrr (nth 1 cmd))
869 ;; (RRR (nth 2 cmd))
870 ;; (rrr (nth 3 cmd)))
871 ;; (ccl-check-register rrr cmd)
872 ;; (ccl-check-register RRR cmd)
873 ;; (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
874 ;; (if (not (get Rrr 'translation-table))
875 ;; (error "CCL: Invalid translation table %s in %s" Rrr cmd))
876 ;; (ccl-embed-extended-command 'translate-character-const-tbl
877 ;; rrr RRR 0)
878 ;; (ccl-embed-data Rrr))
879 ;; (t
880 ;; (ccl-check-register Rrr cmd)
881 ;; (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
882 ;; nil)
883
884 ;; (defun ccl-compile-iterate-multiple-map (cmd)
885 ;; (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
886 ;; nil)
887
888 ;; (defun ccl-compile-map-multiple (cmd)
889 ;; (if (/= (length cmd) 4)
890 ;; (error "CCL: Invalid number of arguments: %s" cmd))
891 ;; (let ((func '(lambda (arg mp)
892 ;; (let ((len 0) result add)
893 ;; (while arg
894 ;; (if (consp (car arg))
895 ;; (setq add (funcall func (car arg) t)
896 ;; result (append result add)
897 ;; add (+ (-(car add)) 1))
898 ;; (setq result
899 ;; (append result
900 ;; (list (car arg)))
901 ;; add 1))
902 ;; (setq arg (cdr arg)
903 ;; len (+ len add)))
904 ;; (if mp
905 ;; (cons (- len) result)
906 ;; result))))
907 ;; arg)
908 ;; (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
909 ;; (funcall func (nth 3 cmd) nil)))
910 ;; (ccl-compile-multiple-map-function 'map-multiple arg))
911 ;; nil)
912
913 ;; (defun ccl-compile-map-single (cmd)
914 ;; (if (/= (length cmd) 4)
915 ;; (error "CCL: Invalid number of arguments: %s" cmd))
916 ;; (let ((RRR (nth 1 cmd))
917 ;; (rrr (nth 2 cmd))
918 ;; (map (nth 3 cmd))
919 ;; id)
920 ;; (ccl-check-register rrr cmd)
921 ;; (ccl-check-register RRR cmd)
922 ;; (ccl-embed-extended-command 'map-single rrr RRR 0)
923 ;; (cond ((symbolp map)
924 ;; (if (get map 'code-conversion-map)
925 ;; (ccl-embed-data map)
926 ;; (error "CCL: Invalid map: %s" map)))
927 ;; (t
928 ;; (error "CCL: Invalid type of arguments: %s" cmd))))
929 ;; nil)
930
931 ;; (defun ccl-compile-multiple-map-function (command cmd)
932 ;; (if (< (length cmd) 4)
933 ;; (error "CCL: Invalid number of arguments: %s" cmd))
934 ;; (let ((RRR (nth 1 cmd))
935 ;; (rrr (nth 2 cmd))
936 ;; (args (nthcdr 3 cmd))
937 ;; map)
938 ;; (ccl-check-register rrr cmd)
939 ;; (ccl-check-register RRR cmd)
940 ;; (ccl-embed-extended-command command rrr RRR 0)
941 ;; (ccl-embed-data (length args))
942 ;; (while args
943 ;; (setq map (car args))
944 ;; (cond ((symbolp map)
945 ;; (if (get map 'code-conversion-map)
946 ;; (ccl-embed-data map)
947 ;; (error "CCL: Invalid map: %s" map)))
948 ;; ((numberp map)
949 ;; (ccl-embed-data map))
950 ;; (t
951 ;; (error "CCL: Invalid type of arguments: %s" cmd)))
952 ;; (setq args (cdr args)))))
953
954
805 ;;; CCL dump staffs 955 ;;; CCL dump staffs
806 956
807 ;; To avoid byte-compiler warning. 957 ;; To avoid byte-compiler warning.
808 (defvar ccl-code) 958 (defvar ccl-code)
809 959
1067 (if (< code (length ccl-code-table)) 1217 (if (< code (length ccl-code-table))
1068 (insert (format ":%s" (aref ccl-code-table code)))) 1218 (insert (format ":%s" (aref ccl-code-table code))))
1069 (insert "\n")) 1219 (insert "\n"))
1070 (setq i (1+ i))))) 1220 (setq i (1+ i)))))
1071 1221
1222 (defun ccl-dump-ex-cmd (rrr cc)
1223 (let* ((RRR (logand cc ?\x7))
1224 (Rrr (logand (ash cc -3) ?\x7))
1225 (ex-op (aref ccl-extended-code-table (logand (ash cc -6) ?\x3fff))))
1226 (insert (format "<%s> " ex-op))
1227 (funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
1228
1229 (defun ccl-dump-read-multibyte-character (rrr RRR Rrr)
1230 (insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
1231
1232 (defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
1233 (insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
1234
1235 ;; (defun ccl-dump-translate-character (rrr RRR Rrr)
1236 ;; (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
1237
1238 ;; (defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
1239 ;; (let ((tbl (ccl-get-next-code)))
1240 ;; (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
1241
1242 ;; (defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
1243 ;; (let ((notbl (ccl-get-next-code))
1244 ;; (i 0) id)
1245 ;; (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
1246 ;; (insert (format "\tnumber of maps is %d .\n\t [" notbl))
1247 ;; (while (< i notbl)
1248 ;; (setq id (ccl-get-next-code))
1249 ;; (insert (format "%S" id))
1250 ;; (setq i (1+ i)))
1251 ;; (insert "]\n")))
1252
1253 ;; (defun ccl-dump-map-multiple (rrr RRR Rrr)
1254 ;; (let ((notbl (ccl-get-next-code))
1255 ;; (i 0) id)
1256 ;; (insert (format "map-multiple r%d r%d\n" RRR rrr))
1257 ;; (insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
1258 ;; (while (< i notbl)
1259 ;; (setq id (ccl-get-next-code))
1260 ;; (if (= id -1)
1261 ;; (insert "]\n\t [")
1262 ;; (insert (format "%S " id)))
1263 ;; (setq i (1+ i)))
1264 ;; (insert "]\n")))
1265
1266 ;; (defun ccl-dump-map-single (rrr RRR Rrr)
1267 ;; (let ((id (ccl-get-next-code)))
1268 ;; (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
1269
1270
1072 ;; CCL emulation staffs 1271 ;; CCL emulation staffs
1073 1272
1074 ;; Not yet implemented. 1273 ;; Not yet implemented.
1075 1274
1275 ;; Auto-loaded functions.
1276
1076 ;;;###autoload 1277 ;;;###autoload
1077 (defmacro declare-ccl-program (name) 1278 (defmacro declare-ccl-program (name &optional vector)
1078 "Declare NAME as a name of CCL program. 1279 "Declare NAME as a name of CCL program.
1079 1280
1080 To compile a CCL program which calls another CCL program not yet 1281 To compile a CCL program which calls another CCL program not yet
1081 defined, it must be declared as a CCL program in advance." 1282 defined, it must be declared as a CCL program in advance.
1082 `(put ',name 'ccl-program-idx (register-ccl-program ',name nil))) 1283 Optional arg VECTOR is a compiled CCL code of the CCL program."
1284 `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
1083 1285
1084 ;;;###autoload 1286 ;;;###autoload
1085 (defmacro define-ccl-program (name ccl-program &optional doc) 1287 (defmacro define-ccl-program (name ccl-program &optional doc)
1086 "Set NAME the compiled code of CCL-PROGRAM. 1288 "Set NAME the compiled code of CCL-PROGRAM.
1087 CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'. 1289 CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'.
1090 (defconst ,name prog ,doc) 1292 (defconst ,name prog ,doc)
1091 (put ',name 'ccl-program-idx (register-ccl-program ',name prog)) 1293 (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
1092 nil)) 1294 nil))
1093 1295
1094 ;;;###autoload 1296 ;;;###autoload
1297 (defmacro check-ccl-program (ccl-program &optional name)
1298 "Check validity of CCL-PROGRAM.
1299 If CCL-PROGRAM is a symbol denoting a valid CCL program, return
1300 CCL-PROGRAM, else return nil.
1301 If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
1302 register CCL-PROGRAM by name NAME, and return NAME."
1303 `(let ((result ,ccl-program))
1304 (cond ((symbolp ,ccl-program)
1305 (or (numberp (get ,ccl-program 'ccl-program-idx))
1306 (setq result nil)))
1307 ((vectorp ,ccl-program)
1308 (setq result ,name)
1309 (register-ccl-program result ,ccl-program))
1310 (t
1311 (setq result nil)))
1312 result))
1313
1314 ;;;###autoload
1095 (defun ccl-execute-with-args (ccl-prog &rest args) 1315 (defun ccl-execute-with-args (ccl-prog &rest args)
1096 "Execute CCL-PROGRAM with registers initialized by the remaining args. 1316 "Execute CCL-PROGRAM with registers initialized by the remaining args.
1097 The return value is a vector of resulting CCL registeres." 1317 The return value is a vector of resulting CCL registers."
1098 (let ((reg (make-vector 8 0)) 1318 (let ((reg (make-vector 8 0))
1099 (i 0)) 1319 (i 0))
1100 (while (and args (< i 8)) 1320 (while (and args (< i 8))
1101 (if (not (integerp (car args))) 1321 (if (not (integerp (car args)))
1102 (error "Arguments should be integer")) 1322 (error "Arguments should be integer"))