Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-ccl.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 4f79e16b1112
children 697ef44129c6
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
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))
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))))
260 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)))
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
265 ;;;###autoload 300 ;;;###autoload
266 (defun ccl-program-p (obj) 301 (defun ccl-program-p (obj)
267 "T if OBJECT is a valid CCL compiled code." 302 "Return t if OBJECT is a valid CCL compiled code."
268 (and (vectorp obj) 303 (and (vectorp obj)
269 (let ((i 0) (len (length obj)) (flag t)) 304 (let ((i 0) (len (length obj)) (flag t))
270 (if (> len 1) 305 (if (> len 1)
271 (progn 306 (progn
272 (while (and flag (< i len)) 307 (while (and flag (< i len))
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"))