Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-ccl.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 74fd4e045ea6
children 95016f13131a
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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})
78 ;; WRITE := 77 ;; WRITE :=
79 ;; (write REG ...) 78 ;; (write REG ...)
80 ;; | (write EXPRESSION) 79 ;; | (write EXPRESSION)
81 ;; | (write integer) | (write string) | (write REG ARRAY) 80 ;; | (write integer) | (write string) | (write REG ARRAY)
82 ;; | string 81 ;; | string
83 ;; | (write-multibyte-character REG(charset) REG(codepoint))
84 ;; CALL := (call ccl-program-name) 82 ;; CALL := (call ccl-program-name)
85 ;; END := (end) 83 ;; END := (end)
86 ;; 84 ;;
87 ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 85 ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
88 ;; ARG := REG | integer 86 ;; ARG := REG | integer
89 ;; OPERATOR := 87 ;; OPERATOR :=
90 ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // 88 ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
91 ;; | < | > | == | <= | >= | != | de-sjis | en-sjis 89 ;; | < | > | == | <= | >= | != | de-sjis | en-sjis
92 ;; ASSIGNMENT_OPERATOR := 90 ;; ASSIGNMENT_OPERATOR :=
93 ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= 91 ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
94 ;; ARRAY := '[' integer ... ']' 92 ;; ARRAY := '[' interger ... ']'
95 93
96 ;;; Code: 94 ;;; Code:
97 95
98 (defconst ccl-command-table 96 (defconst ccl-command-table
99 [if branch loop break repeat write-repeat write-read-repeat 97 [if branch loop break repeat write-repeat write-read-repeat
100 read read-if read-branch write call end 98 read read-if read-branch write call end]
101 read-multibyte-character write-multibyte-character] 99 "*Vector of CCL commands (symbols).")
102 "Vector of CCL commands (symbols).")
103 100
104 ;; Put a property to each symbol of CCL commands for the compiler. 101 ;; Put a property to each symbol of CCL commands for the compiler.
105 (let (op (i 0) (len (length ccl-command-table))) 102 (let (op (i 0) (len (length ccl-command-table)))
106 (while (< i len) 103 (while (< i len)
107 (setq op (aref ccl-command-table i)) 104 (setq op (aref ccl-command-table i))
138 set-expr-register 135 set-expr-register
139 jump-cond-expr-const 136 jump-cond-expr-const
140 jump-cond-expr-register 137 jump-cond-expr-register
141 read-jump-cond-expr-const 138 read-jump-cond-expr-const
142 read-jump-cond-expr-register 139 read-jump-cond-expr-register
143 ex-cmd
144 ] 140 ]
145 "Vector of CCL compiled codes (symbols).") 141 "*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).")
158 142
159 ;; Put a property to each symbol of CCL codes for the disassembler. 143 ;; Put a property to each symbol of CCL codes for the disassembler.
160 (let (code (i 0) (len (length ccl-code-table))) 144 (let (code (i 0) (len (length ccl-code-table)))
161 (while (< i len) 145 (while (< i len)
162 (setq code (aref ccl-code-table i)) 146 (setq code (aref ccl-code-table i))
163 (put code 'ccl-code i) 147 (put code 'ccl-code i)
164 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code))) 148 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
165 (setq i (1+ i)))) 149 (setq i (1+ i))))
166 150
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
176 (defconst ccl-jump-code-list 151 (defconst ccl-jump-code-list
177 '(jump jump-cond write-register-jump write-register-read-jump 152 '(jump jump-cond write-register-jump write-register-read-jump
178 write-const-jump write-const-read-jump write-string-jump 153 write-const-jump write-const-read-jump write-string-jump
179 write-array-read-jump read-jump)) 154 write-array-read-jump read-jump))
180 155
185 (put (car l) 'jump-flag t) 160 (put (car l) 'jump-flag t)
186 (setq l (cdr l)))) 161 (setq l (cdr l))))
187 162
188 (defconst ccl-register-table 163 (defconst ccl-register-table
189 [r0 r1 r2 r3 r4 r5 r6 r7] 164 [r0 r1 r2 r3 r4 r5 r6 r7]
190 "Vector of CCL registers (symbols).") 165 "*Vector of CCL registers (symbols).")
191 166
192 ;; Put a property to indicate register number to each symbol of CCL. 167 ;; Put a property to indicate register number to each symbol of CCL.
193 ;; registers. 168 ;; registers.
194 (let (reg (i 0) (len (length ccl-register-table))) 169 (let (reg (i 0) (len (length ccl-register-table)))
195 (while (< i len) 170 (while (< i len)
198 (setq i (1+ i)))) 173 (setq i (1+ i))))
199 174
200 (defconst ccl-arith-table 175 (defconst ccl-arith-table
201 [+ - * / % & | ^ << >> <8 >8 // nil nil nil 176 [+ - * / % & | ^ << >> <8 >8 // nil nil nil
202 < > == <= >= != de-sjis en-sjis] 177 < > == <= >= != de-sjis en-sjis]
203 "Vector of CCL arithmetic/logical operators (symbols).") 178 "*Vector of CCL arithmetic/logical operators (symbols).")
204 179
205 ;; Put a property to each symbol of CCL operators for the compiler. 180 ;; Put a property to each symbol of CCL operators for the compiler.
206 (let (arith (i 0) (len (length ccl-arith-table))) 181 (let (arith (i 0) (len (length ccl-arith-table)))
207 (while (< i len) 182 (while (< i len)
208 (setq arith (aref ccl-arith-table i)) 183 (setq arith (aref ccl-arith-table i))
209 (if arith (put arith 'ccl-arith-code i)) 184 (if arith (put arith 'ccl-arith-code i))
210 (setq i (1+ i)))) 185 (setq i (1+ i))))
211 186
212 (defconst ccl-assign-arith-table 187 (defconst ccl-assign-arith-table
213 [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=] 188 [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
214 "Vector of CCL assignment operators (symbols).") 189 "*Vector of CCL assignment operators (symbols).")
215 190
216 ;; Put a property to each symbol of CCL assignment operators for the compiler. 191 ;; Put a property to each symbol of CCL assignment operators for the compiler.
217 (let (arith (i 0) (len (length ccl-assign-arith-table))) 192 (let (arith (i 0) (len (length ccl-assign-arith-table)))
218 (while (< i len) 193 (while (< i len)
219 (setq arith (aref ccl-assign-arith-table i)) 194 (setq arith (aref ccl-assign-arith-table i))
281 (ash data 11)) 256 (ash data 11))
282 (ash data 8))))) 257 (ash data 8)))))
283 (aset ccl-program-vector ccl-current-ic code) 258 (aset ccl-program-vector ccl-current-ic code)
284 (setq ccl-current-ic (1+ ccl-current-ic)))) 259 (setq ccl-current-ic (1+ ccl-current-ic))))
285 260
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
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 265 ;;;###autoload
301 (defun ccl-program-p (obj) 266 (defun ccl-program-p (obj)
302 "Return t if OBJECT is a valid CCL compiled code." 267 "T if OBJECT is a valid CCL compiled code."
303 (and (vectorp obj) 268 (and (vectorp obj)
304 (let ((i 0) (len (length obj)) (flag t)) 269 (let ((i 0) (len (length obj)) (flag t))
305 (if (> len 1) 270 (if (> len 1)
306 (progn 271 (progn
307 (while (and flag (< i len)) 272 (while (and flag (< i len))
557 522
558 ;; Compile TRUE-PART. 523 ;; Compile TRUE-PART.
559 (let ((unconditional-jump (ccl-compile-1 true-cmds))) 524 (let ((unconditional-jump (ccl-compile-1 true-cmds)))
560 (if (null false-cmds) 525 (if (null false-cmds)
561 ;; This is the place to jump to if condition is false. 526 ;; This is the place to jump to if condition is false.
562 (progn 527 (ccl-embed-current-address jump-cond-address)
563 (ccl-embed-current-address jump-cond-address)
564 (setq unconditional-jump nil))
565 (let (end-true-part-address) 528 (let (end-true-part-address)
566 (if (not unconditional-jump) 529 (if (not unconditional-jump)
567 (progn 530 (progn
568 ;; If TRUE-PART does not end with unconditional jump, we 531 ;; If TRUE-PART does not end with unconditional jump, we
569 ;; have to jump to the end of FALSE-PART from here. 532 ;; have to jump to the end of FALSE-PART from here.
837 (if (/= (length cmd) 1) 800 (if (/= (length cmd) 1)
838 (error "CCL: Invalid number of arguments: %s" cmd)) 801 (error "CCL: Invalid number of arguments: %s" cmd))
839 (ccl-embed-code 'end 0 0) 802 (ccl-embed-code 'end 0 0)
840 t) 803 t)
841 804
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
955 ;;; CCL dump staffs 805 ;;; CCL dump staffs
956 806
957 ;; To avoid byte-compiler warning. 807 ;; To avoid byte-compiler warning.
958 (defvar ccl-code) 808 (defvar ccl-code)
959 809
1217 (if (< code (length ccl-code-table)) 1067 (if (< code (length ccl-code-table))
1218 (insert (format ":%s" (aref ccl-code-table code)))) 1068 (insert (format ":%s" (aref ccl-code-table code))))
1219 (insert "\n")) 1069 (insert "\n"))
1220 (setq i (1+ i))))) 1070 (setq i (1+ i)))))
1221 1071
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
1271 ;; CCL emulation staffs 1072 ;; CCL emulation staffs
1272 1073
1273 ;; Not yet implemented. 1074 ;; Not yet implemented.
1274 1075
1275 ;; Auto-loaded functions.
1276
1277 ;;;###autoload 1076 ;;;###autoload
1278 (defmacro declare-ccl-program (name &optional vector) 1077 (defmacro declare-ccl-program (name)
1279 "Declare NAME as a name of CCL program. 1078 "Declare NAME as a name of CCL program.
1280 1079
1281 To compile a CCL program which calls another CCL program not yet 1080 To compile a CCL program which calls another CCL program not yet
1282 defined, it must be declared as a CCL program in advance. 1081 defined, it must be declared as a CCL program in advance."
1283 Optional arg VECTOR is a compiled CCL code of the CCL program." 1082 `(put ',name 'ccl-program-idx (register-ccl-program ',name nil)))
1284 `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
1285 1083
1286 ;;;###autoload 1084 ;;;###autoload
1287 (defmacro define-ccl-program (name ccl-program &optional doc) 1085 (defmacro define-ccl-program (name ccl-program &optional doc)
1288 "Set NAME the compiled code of CCL-PROGRAM. 1086 "Set NAME the compiled code of CCL-PROGRAM.
1289 CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'. 1087 CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'.
1292 (defconst ,name prog ,doc) 1090 (defconst ,name prog ,doc)
1293 (put ',name 'ccl-program-idx (register-ccl-program ',name prog)) 1091 (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
1294 nil)) 1092 nil))
1295 1093
1296 ;;;###autoload 1094 ;;;###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
1315 (defun ccl-execute-with-args (ccl-prog &rest args) 1095 (defun ccl-execute-with-args (ccl-prog &rest args)
1316 "Execute CCL-PROGRAM with registers initialized by the remaining args. 1096 "Execute CCL-PROGRAM with registers initialized by the remaining args.
1317 The return value is a vector of resulting CCL registers." 1097 The return value is a vector of resulting CCL registeres."
1318 (let ((reg (make-vector 8 0)) 1098 (let ((reg (make-vector 8 0))
1319 (i 0)) 1099 (i 0))
1320 (while (and args (< i 8)) 1100 (while (and args (< i 8))
1321 (if (not (integerp (car args))) 1101 (if (not (integerp (car args)))
1322 (error "Arguments should be integer")) 1102 (error "Arguments should be integer"))