Line data Source code
1 : ;;; ccl.el --- CCL (Code Conversion Language) compiler -*- lexical-binding:t -*-
2 :
3 : ;; Copyright (C) 1997-1998, 2001-2017 Free Software Foundation, Inc.
4 : ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 : ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
6 : ;; National Institute of Advanced Industrial Science and Technology (AIST)
7 : ;; Registration Number H14PRO021
8 :
9 : ;; Keywords: CCL, mule, multilingual, character set, coding-system
10 :
11 : ;; This file is part of GNU Emacs.
12 :
13 : ;; GNU Emacs is free software: you can redistribute it and/or modify
14 : ;; it under the terms of the GNU General Public License as published by
15 : ;; the Free Software Foundation, either version 3 of the License, or
16 : ;; (at your option) any later version.
17 :
18 : ;; GNU Emacs is distributed in the hope that it will be useful,
19 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 : ;; GNU General Public License for more details.
22 :
23 : ;; You should have received a copy of the GNU General Public License
24 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 :
26 : ;;; Commentary:
27 :
28 : ;; CCL (Code Conversion Language) is a simple programming language to
29 : ;; be used for various kind of code conversion. A CCL program is
30 : ;; compiled to CCL code (vector of integers) and executed by the CCL
31 : ;; interpreter in Emacs.
32 : ;;
33 : ;; CCL is used for code conversion at process I/O and file I/O for
34 : ;; non-standard coding-systems. In addition, it is used for
35 : ;; calculating code points of X fonts from character codes.
36 : ;; However, since CCL is designed as a powerful programming language,
37 : ;; it can be used for more generic calculation. For instance,
38 : ;; combination of three or more arithmetic operations can be
39 : ;; calculated faster than in Emacs Lisp.
40 : ;;
41 : ;; The syntax and semantics of CCL programs are described in the
42 : ;; documentation of `define-ccl-program'.
43 :
44 : ;;; Code:
45 :
46 : ;; Unused.
47 : ;;; (defgroup ccl nil
48 : ;;; "CCL (Code Conversion Language) compiler."
49 : ;;; :prefix "ccl-"
50 : ;;; :group 'i18n)
51 :
52 : (defconst ccl-command-table
53 : [if branch loop break repeat write-repeat write-read-repeat
54 : read read-if read-branch write call end
55 : read-multibyte-character write-multibyte-character
56 : translate-character
57 : iterate-multiple-map map-multiple map-single lookup-integer
58 : lookup-character]
59 : "Vector of CCL commands (symbols).")
60 :
61 : ;; Put a property to each symbol of CCL commands for the compiler.
62 : (let (op (i 0) (len (length ccl-command-table)))
63 : (while (< i len)
64 : (setq op (aref ccl-command-table i))
65 : (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
66 : (setq i (1+ i))))
67 :
68 : (defconst ccl-code-table
69 : [set-register
70 : set-short-const
71 : set-const
72 : set-array
73 : jump
74 : jump-cond
75 : write-register-jump
76 : write-register-read-jump
77 : write-const-jump
78 : write-const-read-jump
79 : write-string-jump
80 : write-array-read-jump
81 : read-jump
82 : branch
83 : read-register
84 : write-expr-const
85 : read-branch
86 : write-register
87 : write-expr-register
88 : call
89 : write-const-string
90 : write-array
91 : end
92 : set-assign-expr-const
93 : set-assign-expr-register
94 : set-expr-const
95 : set-expr-register
96 : jump-cond-expr-const
97 : jump-cond-expr-register
98 : read-jump-cond-expr-const
99 : read-jump-cond-expr-register
100 : ex-cmd
101 : ]
102 : "Vector of CCL compiled codes (symbols).")
103 :
104 : (defconst ccl-extended-code-table
105 : [read-multibyte-character
106 : write-multibyte-character
107 : translate-character
108 : translate-character-const-tbl
109 : nil nil nil nil nil nil nil nil nil nil nil nil ; 0x04-0x0f
110 : iterate-multiple-map
111 : map-multiple
112 : map-single
113 : lookup-int-const-tbl
114 : lookup-char-const-tbl
115 : ]
116 : "Vector of CCL extended compiled codes (symbols).")
117 :
118 : ;; Put a property to each symbol of CCL codes for the disassembler.
119 : (let (code (i 0) (len (length ccl-code-table)))
120 : (while (< i len)
121 : (setq code (aref ccl-code-table i))
122 : (put code 'ccl-code i)
123 : (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
124 : (setq i (1+ i))))
125 :
126 : (let (code (i 0) (len (length ccl-extended-code-table)))
127 : (while (< i len)
128 : (setq code (aref ccl-extended-code-table i))
129 : (if code
130 : (progn
131 : (put code 'ccl-ex-code i)
132 : (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))))
133 : (setq i (1+ i))))
134 :
135 : (defconst ccl-jump-code-list
136 : '(jump jump-cond write-register-jump write-register-read-jump
137 : write-const-jump write-const-read-jump write-string-jump
138 : write-array-read-jump read-jump))
139 :
140 : ;; Put a property `jump-flag' to each CCL code which execute jump in
141 : ;; some way.
142 : (let ((l ccl-jump-code-list))
143 : (while l
144 : (put (car l) 'jump-flag t)
145 : (setq l (cdr l))))
146 :
147 : (defconst ccl-register-table
148 : [r0 r1 r2 r3 r4 r5 r6 r7]
149 : "Vector of CCL registers (symbols).")
150 :
151 : ;; Put a property to indicate register number to each symbol of CCL.
152 : ;; registers.
153 : (let (reg (i 0) (len (length ccl-register-table)))
154 : (while (< i len)
155 : (setq reg (aref ccl-register-table i))
156 : (put reg 'ccl-register-number i)
157 : (setq i (1+ i))))
158 :
159 : (defconst ccl-arith-table
160 : [+ - * / % & | ^ << >> <8 >8 // nil nil nil
161 : < > == <= >= != de-sjis en-sjis]
162 : "Vector of CCL arithmetic/logical operators (symbols).")
163 :
164 : ;; Put a property to each symbol of CCL operators for the compiler.
165 : (let (arith (i 0) (len (length ccl-arith-table)))
166 : (while (< i len)
167 : (setq arith (aref ccl-arith-table i))
168 : (if arith (put arith 'ccl-arith-code i))
169 : (setq i (1+ i))))
170 :
171 : (defconst ccl-assign-arith-table
172 : [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
173 : "Vector of CCL assignment operators (symbols).")
174 :
175 : ;; Put a property to each symbol of CCL assignment operators for the compiler.
176 : (let (arith (i 0) (len (length ccl-assign-arith-table)))
177 : (while (< i len)
178 : (setq arith (aref ccl-assign-arith-table i))
179 : (put arith 'ccl-self-arith-code i)
180 : (setq i (1+ i))))
181 :
182 : (defvar ccl-program-vector nil
183 : "Working vector of CCL codes produced by CCL compiler.")
184 : (defvar ccl-current-ic 0
185 : "The current index for `ccl-program-vector'.")
186 :
187 : (defun ccl-embed-data (data &optional ic)
188 : "Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
189 : increment it. If IC is specified, embed DATA at IC."
190 0 : (if ic
191 0 : (aset ccl-program-vector ic data)
192 0 : (let ((len (length ccl-program-vector)))
193 0 : (if (>= ccl-current-ic len)
194 0 : (let ((new (make-vector (* len 2) nil)))
195 0 : (while (> len 0)
196 0 : (setq len (1- len))
197 0 : (aset new len (aref ccl-program-vector len)))
198 0 : (setq ccl-program-vector new))))
199 0 : (aset ccl-program-vector ccl-current-ic data)
200 0 : (setq ccl-current-ic (1+ ccl-current-ic))))
201 :
202 : (defun ccl-embed-symbol (symbol prop)
203 : "Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
204 : proper index number for SYMBOL. PROP should be
205 : `translation-table-id', `translation-hash-table-id'
206 : `code-conversion-map-id', or `ccl-program-idx'."
207 0 : (ccl-embed-data (cons symbol prop)))
208 :
209 : (defun ccl-embed-string (len str)
210 : "Embed string STR of length LEN in `ccl-program-vector' at
211 : `ccl-current-ic'."
212 0 : (if (> len #xFFFFF)
213 0 : (error "CCL: String too long: %d" len))
214 0 : (if (> (string-bytes str) len)
215 0 : (dotimes (i len)
216 0 : (ccl-embed-data (logior #x1000000 (aref str i))))
217 0 : (let ((i 0))
218 0 : (while (< i len)
219 0 : (ccl-embed-data (logior (ash (aref str i) 16)
220 0 : (if (< (1+ i) len)
221 0 : (ash (aref str (1+ i)) 8)
222 0 : 0)
223 0 : (if (< (+ i 2) len)
224 0 : (aref str (+ i 2))
225 0 : 0)))
226 0 : (setq i (+ i 3))))))
227 :
228 : (defun ccl-embed-current-address (ic)
229 : "Embed a relative jump address to `ccl-current-ic' in
230 : `ccl-program-vector' at IC without altering the other bit field."
231 0 : (let ((relative (- ccl-current-ic (1+ ic))))
232 0 : (aset ccl-program-vector ic
233 0 : (logior (aref ccl-program-vector ic) (ash relative 8)))))
234 :
235 : (defun ccl-embed-code (op reg data &optional reg2)
236 : "Embed CCL code for the operation OP and arguments REG and DATA in
237 : `ccl-program-vector' at `ccl-current-ic' in the following format.
238 : |----------------- integer (28-bit) ------------------|
239 : |------------ 20-bit ------------|- 3-bit --|- 5-bit -|
240 : |------------- DATA -------------|-- REG ---|-- OP ---|
241 : If REG2 is specified, embed a code in the following format.
242 : |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
243 : |-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
244 :
245 : If REG is a CCL register symbol (e.g. r0, r1...), the register
246 : number is embedded. If OP is one of unconditional jumps, DATA is
247 : changed to a relative jump address."
248 0 : (if (and (> data 0) (get op 'jump-flag))
249 : ;; DATA is an absolute jump address. Make it relative to the
250 : ;; next of jump code.
251 0 : (setq data (- data (1+ ccl-current-ic))))
252 0 : (let ((code (logior (get op 'ccl-code)
253 0 : (ash
254 0 : (if (symbolp reg) (get reg 'ccl-register-number) reg) 5)
255 0 : (if reg2
256 0 : (logior (ash (get reg2 'ccl-register-number) 8)
257 0 : (ash data 11))
258 0 : (ash data 8)))))
259 0 : (ccl-embed-data code)))
260 :
261 : (defun ccl-embed-extended-command (ex-op reg reg2 reg3)
262 : "extended ccl command format
263 : |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
264 : |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|"
265 0 : (let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
266 0 : (if (symbolp reg3)
267 0 : (get reg3 'ccl-register-number)
268 0 : 0))))
269 0 : (ccl-embed-code 'ex-cmd reg data reg2)))
270 :
271 : (defun ccl-increment-ic (inc)
272 : "Just advance `ccl-current-ic' by INC."
273 0 : (setq ccl-current-ic (+ ccl-current-ic inc)))
274 :
275 : (defvar ccl-loop-head nil
276 : "If non-nil, index of the start of the current loop.")
277 : (defvar ccl-breaks nil
278 : "If non-nil, list of absolute addresses of the breaking points of
279 : the current loop.")
280 :
281 : ;;;###autoload
282 : (defun ccl-compile (ccl-program)
283 : "Return the compiled code of CCL-PROGRAM as a vector of integers."
284 0 : (unless (and (consp ccl-program)
285 0 : (integerp (car ccl-program))
286 0 : (listp (car (cdr ccl-program))))
287 0 : (error "CCL: Invalid CCL program: %s" ccl-program))
288 0 : (if (null (vectorp ccl-program-vector))
289 0 : (setq ccl-program-vector (make-vector 8192 0)))
290 0 : (setq ccl-loop-head nil ccl-breaks nil)
291 0 : (setq ccl-current-ic 0)
292 :
293 : ;; The first element is the buffer magnification.
294 0 : (ccl-embed-data (car ccl-program))
295 :
296 : ;; The second element is the address of the start CCL code for
297 : ;; processing end of input buffer (we call it eof-processor). We
298 : ;; set it later.
299 0 : (ccl-increment-ic 1)
300 :
301 : ;; Compile the main body of the CCL program.
302 0 : (ccl-compile-1 (car (cdr ccl-program)))
303 :
304 : ;; Embed the address of eof-processor.
305 0 : (ccl-embed-data ccl-current-ic 1)
306 :
307 : ;; Then compile eof-processor.
308 0 : (if (nth 2 ccl-program)
309 0 : (ccl-compile-1 (nth 2 ccl-program)))
310 :
311 : ;; At last, embed termination code.
312 0 : (ccl-embed-code 'end 0 0)
313 :
314 0 : (let ((vec (make-vector ccl-current-ic 0))
315 : (i 0))
316 0 : (while (< i ccl-current-ic)
317 0 : (aset vec i (aref ccl-program-vector i))
318 0 : (setq i (1+ i)))
319 0 : vec))
320 :
321 : (defun ccl-syntax-error (cmd)
322 : "Signal syntax error."
323 0 : (error "CCL: Syntax error: %s" cmd))
324 :
325 : (defun ccl-check-register (arg cmd)
326 : "Check if ARG is a valid CCL register."
327 0 : (if (get arg 'ccl-register-number)
328 0 : arg
329 0 : (error "CCL: Invalid register %s in %s" arg cmd)))
330 :
331 : (defun ccl-check-compile-function (arg cmd)
332 : "Check if ARG is a valid CCL command."
333 0 : (or (get arg 'ccl-compile-function)
334 0 : (error "CCL: Invalid command: %s" cmd)))
335 :
336 : ;; In the following code, most ccl-compile-XXXX functions return t if
337 : ;; they end with unconditional jump, else return nil.
338 :
339 : (defun ccl-compile-1 (ccl-block)
340 : "Compile CCL-BLOCK (see the syntax above)."
341 0 : (let (unconditional-jump
342 : cmd)
343 0 : (if (or (integerp ccl-block)
344 0 : (stringp ccl-block)
345 0 : (and ccl-block (symbolp (car ccl-block))))
346 : ;; This block consists of single statement.
347 0 : (setq ccl-block (list ccl-block)))
348 :
349 : ;; Now CCL-BLOCK is a list of statements. Compile them one by
350 : ;; one.
351 0 : (while ccl-block
352 0 : (setq cmd (car ccl-block))
353 0 : (setq unconditional-jump
354 0 : (cond ((integerp cmd)
355 : ;; SET statement for the register 0.
356 0 : (ccl-compile-set (list 'r0 '= cmd)))
357 :
358 0 : ((stringp cmd)
359 : ;; WRITE statement of string argument.
360 0 : (ccl-compile-write-string cmd))
361 :
362 0 : ((listp cmd)
363 : ;; The other statements.
364 0 : (cond ((eq (nth 1 cmd) '=)
365 : ;; SET statement of the form `(REG = EXPRESSION)'.
366 0 : (ccl-compile-set cmd))
367 :
368 0 : ((and (symbolp (nth 1 cmd))
369 0 : (get (nth 1 cmd) 'ccl-self-arith-code))
370 : ;; SET statement with an assignment operation.
371 0 : (ccl-compile-self-set cmd))
372 :
373 : (t
374 0 : (funcall (ccl-check-compile-function (car cmd) cmd)
375 0 : cmd))))
376 :
377 : (t
378 0 : (ccl-syntax-error cmd))))
379 0 : (setq ccl-block (cdr ccl-block)))
380 0 : unconditional-jump))
381 :
382 : (defconst ccl-max-short-const (ash 1 19))
383 : (defconst ccl-min-short-const (ash -1 19))
384 :
385 : (defun ccl-compile-set (cmd)
386 : "Compile SET statement."
387 0 : (let ((rrr (ccl-check-register (car cmd) cmd))
388 0 : (right (nth 2 cmd)))
389 0 : (cond ((listp right)
390 : ;; CMD has the form `(RRR = (XXX OP YYY))'.
391 0 : (ccl-compile-expression rrr right))
392 :
393 0 : ((integerp right)
394 : ;; CMD has the form `(RRR = integer)'.
395 0 : (if (and (<= right ccl-max-short-const)
396 0 : (>= right ccl-min-short-const))
397 0 : (ccl-embed-code 'set-short-const rrr right)
398 0 : (ccl-embed-code 'set-const rrr 0)
399 0 : (ccl-embed-data right)))
400 :
401 : (t
402 : ;; CMD has the form `(RRR = rrr [ array ])'.
403 0 : (ccl-check-register right cmd)
404 0 : (let ((ary (nth 3 cmd)))
405 0 : (if (vectorp ary)
406 0 : (let ((i 0) (len (length ary)))
407 0 : (ccl-embed-code 'set-array rrr len right)
408 0 : (while (< i len)
409 0 : (ccl-embed-data (aref ary i))
410 0 : (setq i (1+ i))))
411 0 : (ccl-embed-code 'set-register rrr 0 right))))))
412 : nil)
413 :
414 : (defun ccl-compile-self-set (cmd)
415 : "Compile SET statement with ASSIGNMENT_OPERATOR."
416 0 : (let ((rrr (ccl-check-register (car cmd) cmd))
417 0 : (right (nth 2 cmd)))
418 0 : (if (listp right)
419 : ;; CMD has the form `(RRR ASSIGN_OP (XXX OP YYY))', compile
420 : ;; the right hand part as `(r7 = (XXX OP YYY))' (note: the
421 : ;; register 7 can be used for storing temporary value).
422 0 : (progn
423 0 : (ccl-compile-expression 'r7 right)
424 0 : (setq right 'r7)))
425 : ;; Now CMD has the form `(RRR ASSIGN_OP ARG)'. Compile it as
426 : ;; `(RRR = (RRR OP ARG))'.
427 0 : (ccl-compile-expression
428 0 : rrr
429 0 : (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
430 : nil)
431 :
432 : (defun ccl-compile-expression (rrr expr)
433 : "Compile SET statement of the form `(RRR = EXPR)'."
434 0 : (let ((left (car expr))
435 0 : (op (get (nth 1 expr) 'ccl-arith-code))
436 0 : (right (nth 2 expr)))
437 0 : (if (listp left)
438 0 : (progn
439 : ;; EXPR has the form `((EXPR2 OP2 ARG) OP RIGHT)'. Compile
440 : ;; the first term as `(r7 = (EXPR2 OP2 ARG)).'
441 0 : (ccl-compile-expression 'r7 left)
442 0 : (setq left 'r7)))
443 :
444 : ;; Now EXPR has the form (LEFT OP RIGHT).
445 0 : (if (and (eq rrr left)
446 0 : (< op (length ccl-assign-arith-table)))
447 : ;; Compile this SET statement as `(RRR OP= RIGHT)'.
448 0 : (if (integerp right)
449 0 : (progn
450 0 : (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
451 0 : (ccl-embed-data right))
452 0 : (ccl-check-register right expr)
453 0 : (ccl-embed-code 'set-assign-expr-register rrr (ash op 3) right))
454 :
455 : ;; Compile this SET statement as `(RRR = (LEFT OP RIGHT))'.
456 0 : (if (integerp right)
457 0 : (progn
458 0 : (ccl-embed-code 'set-expr-const rrr (ash op 3) left)
459 0 : (ccl-embed-data right))
460 0 : (ccl-check-register right expr)
461 0 : (ccl-embed-code 'set-expr-register
462 0 : rrr
463 0 : (logior (ash op 3) (get right 'ccl-register-number))
464 0 : left)))))
465 :
466 : (defun ccl-compile-write-string (str)
467 : "Compile WRITE statement with string argument."
468 0 : (let ((len (length str)))
469 0 : (ccl-embed-code 'write-const-string 1 len)
470 0 : (ccl-embed-string len str))
471 : nil)
472 :
473 : (defun ccl-compile-if (cmd &optional read-flag)
474 : "Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
475 : If READ-FLAG is non-nil, this statement has the form
476 : `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'."
477 0 : (if (and (/= (length cmd) 3) (/= (length cmd) 4))
478 0 : (error "CCL: Invalid number of arguments: %s" cmd))
479 0 : (let ((condition (nth 1 cmd))
480 0 : (true-cmds (nth 2 cmd))
481 0 : (false-cmds (nth 3 cmd))
482 : jump-cond-address)
483 0 : (if (and (listp condition)
484 0 : (listp (car condition)))
485 : ;; If CONDITION is a nested expression, the inner expression
486 : ;; should be compiled at first as SET statement, i.e.:
487 : ;; `(if ((X OP2 Y) OP Z) ...)' is compiled into two statements:
488 : ;; `(r7 = (X OP2 Y)) (if (r7 OP Z) ...)'.
489 0 : (progn
490 0 : (ccl-compile-expression 'r7 (car condition))
491 0 : (setq condition (cons 'r7 (cdr condition)))
492 0 : (setq cmd (cons (car cmd)
493 0 : (cons condition (cdr (cdr cmd)))))))
494 :
495 0 : (setq jump-cond-address ccl-current-ic)
496 : ;; Compile CONDITION.
497 0 : (if (symbolp condition)
498 : ;; CONDITION is a register.
499 0 : (progn
500 0 : (ccl-check-register condition cmd)
501 0 : (ccl-embed-code 'jump-cond condition 0))
502 : ;; CONDITION is a simple expression of the form (RRR OP ARG).
503 0 : (let ((rrr (car condition))
504 0 : (op (get (nth 1 condition) 'ccl-arith-code))
505 0 : (arg (nth 2 condition)))
506 0 : (ccl-check-register rrr cmd)
507 0 : (or (integerp op)
508 0 : (error "CCL: invalid operator: %s" (nth 1 condition)))
509 0 : (if (integerp arg)
510 0 : (progn
511 0 : (ccl-embed-code (if read-flag 'read-jump-cond-expr-const
512 0 : 'jump-cond-expr-const)
513 0 : rrr 0)
514 0 : (ccl-embed-data op)
515 0 : (ccl-embed-data arg))
516 0 : (ccl-check-register arg cmd)
517 0 : (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
518 0 : 'jump-cond-expr-register)
519 0 : rrr 0)
520 0 : (ccl-embed-data op)
521 0 : (ccl-embed-data (get arg 'ccl-register-number)))))
522 :
523 : ;; Compile TRUE-PART.
524 0 : (let ((unconditional-jump (ccl-compile-1 true-cmds)))
525 0 : (if (null false-cmds)
526 : ;; This is the place to jump to if condition is false.
527 0 : (progn
528 0 : (ccl-embed-current-address jump-cond-address)
529 0 : (setq unconditional-jump nil))
530 0 : (let (end-true-part-address)
531 0 : (if (not unconditional-jump)
532 0 : (progn
533 : ;; If TRUE-PART does not end with unconditional jump, we
534 : ;; have to jump to the end of FALSE-PART from here.
535 0 : (setq end-true-part-address ccl-current-ic)
536 0 : (ccl-embed-code 'jump 0 0)))
537 : ;; This is the place to jump to if CONDITION is false.
538 0 : (ccl-embed-current-address jump-cond-address)
539 : ;; Compile FALSE-PART.
540 0 : (setq unconditional-jump
541 0 : (and (ccl-compile-1 false-cmds) unconditional-jump))
542 0 : (if end-true-part-address
543 : ;; This is the place to jump to after the end of TRUE-PART.
544 0 : (ccl-embed-current-address end-true-part-address))))
545 0 : unconditional-jump)))
546 :
547 : (defun ccl-compile-branch (cmd)
548 : "Compile BRANCH statement."
549 0 : (if (< (length cmd) 3)
550 0 : (error "CCL: Invalid number of arguments: %s" cmd))
551 0 : (ccl-compile-branch-blocks 'branch
552 0 : (ccl-compile-branch-expression (nth 1 cmd) cmd)
553 0 : (cdr (cdr cmd))))
554 :
555 : (defun ccl-compile-read-branch (cmd)
556 : "Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'."
557 0 : (if (< (length cmd) 3)
558 0 : (error "CCL: Invalid number of arguments: %s" cmd))
559 0 : (ccl-compile-branch-blocks 'read-branch
560 0 : (ccl-compile-branch-expression (nth 1 cmd) cmd)
561 0 : (cdr (cdr cmd))))
562 :
563 : (defun ccl-compile-branch-expression (expr cmd)
564 : "Compile EXPRESSION part of BRANCH statement and return register
565 : which holds a value of the expression."
566 0 : (if (listp expr)
567 : ;; EXPR has the form `(EXPR2 OP ARG)'. Compile it as SET
568 : ;; statement of the form `(r7 = (EXPR2 OP ARG))'.
569 0 : (progn
570 0 : (ccl-compile-expression 'r7 expr)
571 0 : 'r7)
572 0 : (ccl-check-register expr cmd)))
573 :
574 : (defun ccl-compile-branch-blocks (code rrr blocks)
575 : "Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
576 : REG is a register which holds a value of EXPRESSION part. BLOCKs
577 : is a list of CCL-BLOCKs."
578 0 : (let ((branches (length blocks))
579 : branch-idx
580 : jump-table-head-address
581 : empty-block-indexes
582 : block-tail-addresses
583 : block-unconditional-jump)
584 0 : (ccl-embed-code code rrr branches)
585 0 : (setq jump-table-head-address ccl-current-ic)
586 : ;; The size of jump table is the number of blocks plus 1 (for the
587 : ;; case RRR is out of range).
588 0 : (ccl-increment-ic (1+ branches))
589 0 : (setq empty-block-indexes (list branches))
590 : ;; Compile each block.
591 0 : (setq branch-idx 0)
592 0 : (while blocks
593 0 : (if (null (car blocks))
594 : ;; This block is empty.
595 0 : (setq empty-block-indexes (cons branch-idx empty-block-indexes)
596 0 : block-unconditional-jump t)
597 : ;; This block is not empty.
598 0 : (ccl-embed-data (- ccl-current-ic jump-table-head-address)
599 0 : (+ jump-table-head-address branch-idx))
600 0 : (setq block-unconditional-jump (ccl-compile-1 (car blocks)))
601 0 : (if (not block-unconditional-jump)
602 0 : (progn
603 : ;; Jump address of the end of branches are embedded later.
604 : ;; For the moment, just remember where to embed them.
605 0 : (setq block-tail-addresses
606 0 : (cons ccl-current-ic block-tail-addresses))
607 0 : (ccl-embed-code 'jump 0 0))))
608 0 : (setq branch-idx (1+ branch-idx))
609 0 : (setq blocks (cdr blocks)))
610 0 : (if (not block-unconditional-jump)
611 : ;; We don't need jump code at the end of the last block.
612 0 : (setq block-tail-addresses (cdr block-tail-addresses)
613 0 : ccl-current-ic (1- ccl-current-ic)))
614 : ;; Embed jump address at the tailing jump commands of blocks.
615 0 : (while block-tail-addresses
616 0 : (ccl-embed-current-address (car block-tail-addresses))
617 0 : (setq block-tail-addresses (cdr block-tail-addresses)))
618 : ;; For empty blocks, make entries in the jump table point directly here.
619 0 : (while empty-block-indexes
620 0 : (ccl-embed-data (- ccl-current-ic jump-table-head-address)
621 0 : (+ jump-table-head-address (car empty-block-indexes)))
622 0 : (setq empty-block-indexes (cdr empty-block-indexes))))
623 : ;; Branch command ends by unconditional jump if RRR is out of range.
624 : nil)
625 :
626 : (defun ccl-compile-loop (cmd)
627 : "Compile LOOP statement."
628 0 : (if (< (length cmd) 2)
629 0 : (error "CCL: Invalid number of arguments: %s" cmd))
630 0 : (let* ((ccl-loop-head ccl-current-ic)
631 : (ccl-breaks nil)
632 : unconditional-jump)
633 0 : (setq cmd (cdr cmd))
634 0 : (if cmd
635 0 : (progn
636 0 : (setq unconditional-jump t)
637 0 : (while cmd
638 0 : (setq unconditional-jump
639 0 : (and (ccl-compile-1 (car cmd)) unconditional-jump))
640 0 : (setq cmd (cdr cmd)))
641 0 : (if (not ccl-breaks)
642 0 : unconditional-jump
643 : ;; Embed jump address for break statements encountered in
644 : ;; this loop.
645 0 : (while ccl-breaks
646 0 : (ccl-embed-current-address (car ccl-breaks))
647 0 : (setq ccl-breaks (cdr ccl-breaks))))
648 0 : nil))))
649 :
650 : (defun ccl-compile-break (cmd)
651 : "Compile BREAK statement."
652 0 : (if (/= (length cmd) 1)
653 0 : (error "CCL: Invalid number of arguments: %s" cmd))
654 0 : (if (null ccl-loop-head)
655 0 : (error "CCL: No outer loop: %s" cmd))
656 0 : (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
657 0 : (ccl-embed-code 'jump 0 0)
658 : t)
659 :
660 : (defun ccl-compile-repeat (cmd)
661 : "Compile REPEAT statement."
662 0 : (if (/= (length cmd) 1)
663 0 : (error "CCL: Invalid number of arguments: %s" cmd))
664 0 : (if (null ccl-loop-head)
665 0 : (error "CCL: No outer loop: %s" cmd))
666 0 : (ccl-embed-code 'jump 0 ccl-loop-head)
667 : t)
668 :
669 : (defun ccl-compile-write-repeat (cmd)
670 : "Compile WRITE-REPEAT statement."
671 0 : (if (/= (length cmd) 2)
672 0 : (error "CCL: Invalid number of arguments: %s" cmd))
673 0 : (if (null ccl-loop-head)
674 0 : (error "CCL: No outer loop: %s" cmd))
675 0 : (let ((arg (nth 1 cmd)))
676 0 : (cond ((integerp arg)
677 0 : (ccl-embed-code 'write-const-jump 0 ccl-loop-head)
678 0 : (ccl-embed-data arg))
679 0 : ((stringp arg)
680 0 : (let ((len (length arg)))
681 0 : (ccl-embed-code 'write-string-jump 0 ccl-loop-head)
682 0 : (ccl-embed-data len)
683 0 : (ccl-embed-string len arg)))
684 : (t
685 0 : (ccl-check-register arg cmd)
686 0 : (ccl-embed-code 'write-register-jump arg ccl-loop-head))))
687 : t)
688 :
689 : (defun ccl-compile-write-read-repeat (cmd)
690 : "Compile WRITE-READ-REPEAT statement."
691 0 : (if (or (< (length cmd) 2) (> (length cmd) 3))
692 0 : (error "CCL: Invalid number of arguments: %s" cmd))
693 0 : (if (null ccl-loop-head)
694 0 : (error "CCL: No outer loop: %s" cmd))
695 0 : (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
696 0 : (arg (nth 2 cmd)))
697 0 : (cond ((null arg)
698 0 : (ccl-embed-code 'write-register-read-jump rrr ccl-loop-head))
699 0 : ((integerp arg)
700 0 : (ccl-embed-code 'write-const-read-jump rrr arg ccl-loop-head))
701 0 : ((vectorp arg)
702 0 : (let ((len (length arg))
703 : (i 0))
704 0 : (ccl-embed-code 'write-array-read-jump rrr ccl-loop-head)
705 0 : (ccl-embed-data len)
706 0 : (while (< i len)
707 0 : (ccl-embed-data (aref arg i))
708 0 : (setq i (1+ i)))))
709 : (t
710 0 : (error "CCL: Invalid argument %s: %s" arg cmd)))
711 0 : (ccl-embed-code 'read-jump rrr ccl-loop-head))
712 : t)
713 :
714 : (defun ccl-compile-read (cmd)
715 : "Compile READ statement."
716 0 : (if (< (length cmd) 2)
717 0 : (error "CCL: Invalid number of arguments: %s" cmd))
718 0 : (let* ((args (cdr cmd))
719 0 : (i (1- (length args))))
720 0 : (while args
721 0 : (let ((rrr (ccl-check-register (car args) cmd)))
722 0 : (ccl-embed-code 'read-register rrr i)
723 0 : (setq args (cdr args) i (1- i)))))
724 : nil)
725 :
726 : (defun ccl-compile-read-if (cmd)
727 : "Compile READ-IF statement."
728 0 : (ccl-compile-if cmd 'read))
729 :
730 : (defun ccl-compile-write (cmd)
731 : "Compile WRITE statement."
732 0 : (if (< (length cmd) 2)
733 0 : (error "CCL: Invalid number of arguments: %s" cmd))
734 0 : (let ((rrr (nth 1 cmd)))
735 0 : (cond ((integerp rrr)
736 0 : (if (> rrr #xFFFFF)
737 0 : (ccl-compile-write-string (string rrr))
738 0 : (ccl-embed-code 'write-const-string 0 rrr)))
739 0 : ((stringp rrr)
740 0 : (ccl-compile-write-string rrr))
741 0 : ((and (symbolp rrr) (vectorp (nth 2 cmd)))
742 0 : (ccl-check-register rrr cmd)
743 : ;; CMD has the form `(write REG ARRAY)'.
744 0 : (let* ((arg (nth 2 cmd))
745 0 : (len (length arg))
746 : (i 0))
747 0 : (ccl-embed-code 'write-array rrr len)
748 0 : (while (< i len)
749 0 : (if (not (integerp (aref arg i)))
750 0 : (error "CCL: Invalid argument %s: %s" arg cmd))
751 0 : (ccl-embed-data (aref arg i))
752 0 : (setq i (1+ i)))))
753 :
754 0 : ((symbolp rrr)
755 : ;; CMD has the form `(write REG ...)'.
756 0 : (let* ((args (cdr cmd))
757 0 : (i (1- (length args))))
758 0 : (while args
759 0 : (setq rrr (ccl-check-register (car args) cmd))
760 0 : (ccl-embed-code 'write-register rrr i)
761 0 : (setq args (cdr args) i (1- i)))))
762 :
763 0 : ((listp rrr)
764 : ;; CMD has the form `(write (LEFT OP RIGHT))'.
765 0 : (let ((left (car rrr))
766 0 : (op (get (nth 1 rrr) 'ccl-arith-code))
767 0 : (right (nth 2 rrr)))
768 0 : (if (listp left)
769 0 : (progn
770 : ;; RRR has the form `((EXPR OP2 ARG) OP RIGHT)'.
771 : ;; Compile the first term as `(r7 = (EXPR OP2 ARG))'.
772 0 : (ccl-compile-expression 'r7 left)
773 0 : (setq left 'r7)))
774 : ;; Now RRR has the form `(ARG OP RIGHT)'.
775 0 : (if (integerp right)
776 0 : (progn
777 0 : (ccl-embed-code 'write-expr-const 0 (ash op 3) left)
778 0 : (ccl-embed-data right))
779 0 : (ccl-check-register right rrr)
780 0 : (ccl-embed-code 'write-expr-register 0
781 0 : (logior (ash op 3)
782 0 : (get right 'ccl-register-number))
783 0 : left))))
784 :
785 : (t
786 0 : (error "CCL: Invalid argument: %s" cmd))))
787 : nil)
788 :
789 : (defun ccl-compile-call (cmd)
790 : "Compile CALL statement."
791 0 : (if (/= (length cmd) 2)
792 0 : (error "CCL: Invalid number of arguments: %s" cmd))
793 0 : (if (not (symbolp (nth 1 cmd)))
794 0 : (error "CCL: Subroutine should be a symbol: %s" cmd))
795 0 : (ccl-embed-code 'call 1 0)
796 0 : (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx)
797 : nil)
798 :
799 : (defun ccl-compile-end (cmd)
800 : "Compile END statement."
801 0 : (if (/= (length cmd) 1)
802 0 : (error "CCL: Invalid number of arguments: %s" cmd))
803 0 : (ccl-embed-code 'end 0 0)
804 : t)
805 :
806 : (defun ccl-compile-read-multibyte-character (cmd)
807 : "Compile read-multibyte-character"
808 0 : (if (/= (length cmd) 3)
809 0 : (error "CCL: Invalid number of arguments: %s" cmd))
810 0 : (let ((RRR (nth 1 cmd))
811 0 : (rrr (nth 2 cmd)))
812 0 : (ccl-check-register rrr cmd)
813 0 : (ccl-check-register RRR cmd)
814 0 : (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
815 : nil)
816 :
817 : (defun ccl-compile-write-multibyte-character (cmd)
818 : "Compile write-multibyte-character"
819 0 : (if (/= (length cmd) 3)
820 0 : (error "CCL: Invalid number of arguments: %s" cmd))
821 0 : (let ((RRR (nth 1 cmd))
822 0 : (rrr (nth 2 cmd)))
823 0 : (ccl-check-register rrr cmd)
824 0 : (ccl-check-register RRR cmd)
825 0 : (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
826 : nil)
827 :
828 : (defun ccl-compile-translate-character (cmd)
829 : "Compile translate-character."
830 0 : (if (/= (length cmd) 4)
831 0 : (error "CCL: Invalid number of arguments: %s" cmd))
832 0 : (let ((Rrr (nth 1 cmd))
833 0 : (RRR (nth 2 cmd))
834 0 : (rrr (nth 3 cmd)))
835 0 : (ccl-check-register rrr cmd)
836 0 : (ccl-check-register RRR cmd)
837 0 : (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
838 0 : (ccl-embed-extended-command 'translate-character-const-tbl
839 0 : rrr RRR 0)
840 0 : (ccl-embed-symbol Rrr 'translation-table-id))
841 : (t
842 0 : (ccl-check-register Rrr cmd)
843 0 : (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
844 : nil)
845 :
846 : (defun ccl-compile-lookup-integer (cmd)
847 : "Compile lookup-integer."
848 0 : (if (/= (length cmd) 4)
849 0 : (error "CCL: Invalid number of arguments: %s" cmd))
850 0 : (let ((Rrr (nth 1 cmd))
851 0 : (RRR (nth 2 cmd))
852 0 : (rrr (nth 3 cmd)))
853 0 : (ccl-check-register RRR cmd)
854 0 : (ccl-check-register rrr cmd)
855 0 : (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
856 0 : (ccl-embed-extended-command 'lookup-int-const-tbl
857 0 : rrr RRR 0)
858 0 : (ccl-embed-symbol Rrr 'translation-hash-table-id))
859 : (t
860 0 : (error "CCL: non-constant table: %s" cmd)
861 : ;; not implemented:
862 0 : (ccl-check-register Rrr cmd)
863 0 : (ccl-embed-extended-command 'lookup-int rrr RRR 0))))
864 : nil)
865 :
866 : (defun ccl-compile-lookup-character (cmd)
867 : "Compile lookup-character."
868 0 : (if (/= (length cmd) 4)
869 0 : (error "CCL: Invalid number of arguments: %s" cmd))
870 0 : (let ((Rrr (nth 1 cmd))
871 0 : (RRR (nth 2 cmd))
872 0 : (rrr (nth 3 cmd)))
873 0 : (ccl-check-register RRR cmd)
874 0 : (ccl-check-register rrr cmd)
875 0 : (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
876 0 : (ccl-embed-extended-command 'lookup-char-const-tbl
877 0 : rrr RRR 0)
878 0 : (ccl-embed-symbol Rrr 'translation-hash-table-id))
879 : (t
880 0 : (error "CCL: non-constant table: %s" cmd)
881 : ;; not implemented:
882 0 : (ccl-check-register Rrr cmd)
883 0 : (ccl-embed-extended-command 'lookup-char rrr RRR 0))))
884 : nil)
885 :
886 : (defun ccl-compile-iterate-multiple-map (cmd)
887 0 : (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
888 : nil)
889 :
890 : (defun ccl-compile-map-multiple (cmd)
891 0 : (if (/= (length cmd) 4)
892 0 : (error "CCL: Invalid number of arguments: %s" cmd))
893 0 : (let (func arg)
894 0 : (setq func
895 : (lambda (arg mp)
896 0 : (let ((len 0) result add)
897 0 : (while arg
898 0 : (if (consp (car arg))
899 0 : (setq add (funcall func (car arg) t)
900 0 : result (append result add)
901 0 : add (+ (- (car add)) 1))
902 0 : (setq result
903 0 : (append result
904 0 : (list (car arg)))
905 0 : add 1))
906 0 : (setq arg (cdr arg)
907 0 : len (+ len add)))
908 0 : (if mp
909 0 : (cons (- len) result)
910 0 : result))))
911 0 : (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
912 0 : (funcall func (nth 3 cmd) nil)))
913 0 : (ccl-compile-multiple-map-function 'map-multiple arg))
914 : nil)
915 :
916 : (defun ccl-compile-map-single (cmd)
917 0 : (if (/= (length cmd) 4)
918 0 : (error "CCL: Invalid number of arguments: %s" cmd))
919 0 : (let ((RRR (nth 1 cmd))
920 0 : (rrr (nth 2 cmd))
921 0 : (map (nth 3 cmd)))
922 0 : (ccl-check-register rrr cmd)
923 0 : (ccl-check-register RRR cmd)
924 0 : (ccl-embed-extended-command 'map-single rrr RRR 0)
925 0 : (cond ((symbolp map)
926 0 : (if (get map 'code-conversion-map)
927 0 : (ccl-embed-symbol map 'code-conversion-map-id)
928 0 : (error "CCL: Invalid map: %s" map)))
929 : (t
930 0 : (error "CCL: Invalid type of arguments: %s" cmd))))
931 : nil)
932 :
933 : (defun ccl-compile-multiple-map-function (command cmd)
934 0 : (if (< (length cmd) 4)
935 0 : (error "CCL: Invalid number of arguments: %s" cmd))
936 0 : (let ((RRR (nth 1 cmd))
937 0 : (rrr (nth 2 cmd))
938 0 : (args (nthcdr 3 cmd))
939 : map)
940 0 : (ccl-check-register rrr cmd)
941 0 : (ccl-check-register RRR cmd)
942 0 : (ccl-embed-extended-command command rrr RRR 0)
943 0 : (ccl-embed-data (length args))
944 0 : (while args
945 0 : (setq map (car args))
946 0 : (cond ((symbolp map)
947 0 : (if (get map 'code-conversion-map)
948 0 : (ccl-embed-symbol map 'code-conversion-map-id)
949 0 : (error "CCL: Invalid map: %s" map)))
950 0 : ((numberp map)
951 0 : (ccl-embed-data map))
952 : (t
953 0 : (error "CCL: Invalid type of arguments: %s" cmd)))
954 0 : (setq args (cdr args)))))
955 :
956 :
957 : ;;; CCL dump stuff
958 :
959 : (defvar ccl-code)
960 :
961 : ;;;###autoload
962 : (defun ccl-dump (code)
963 : "Disassemble compiled CCL-code CODE."
964 0 : (let* ((ccl-code code)
965 0 : (len (length ccl-code))
966 0 : (buffer-mag (aref ccl-code 0)))
967 0 : (cond ((= buffer-mag 0)
968 0 : (insert (substitute-command-keys "Don't output anything.\n")))
969 0 : ((= buffer-mag 1)
970 0 : (insert "Out-buffer must be as large as in-buffer.\n"))
971 : (t
972 0 : (insert
973 0 : (format "Out-buffer must be %d times bigger than in-buffer.\n"
974 0 : buffer-mag))))
975 0 : (insert "Main-body:\n")
976 0 : (setq ccl-current-ic 2)
977 0 : (if (> (aref ccl-code 1) 0)
978 0 : (progn
979 0 : (while (< ccl-current-ic (aref ccl-code 1))
980 0 : (ccl-dump-1))
981 0 : (insert "At EOF:\n")))
982 0 : (while (< ccl-current-ic len)
983 0 : (ccl-dump-1))
984 0 : ))
985 :
986 : (defun ccl-get-next-code ()
987 : "Return a CCL code in `ccl-code' at `ccl-current-ic'."
988 0 : (prog1
989 0 : (aref ccl-code ccl-current-ic)
990 0 : (setq ccl-current-ic (1+ ccl-current-ic))))
991 :
992 : (defun ccl-dump-1 ()
993 0 : (let* ((code (ccl-get-next-code))
994 0 : (cmd (aref ccl-code-table (logand code 31)))
995 0 : (rrr (ash (logand code 255) -5))
996 0 : (cc (ash code -8)))
997 0 : (insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
998 0 : (funcall (get cmd 'ccl-dump-function) rrr cc)))
999 :
1000 : (defun ccl-dump-set-register (rrr cc)
1001 0 : (insert (format "r%d = r%d\n" rrr cc)))
1002 :
1003 : (defun ccl-dump-set-short-const (rrr cc)
1004 0 : (insert (format "r%d = %d\n" rrr cc)))
1005 :
1006 : (defun ccl-dump-set-const (rrr _ignore)
1007 0 : (insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
1008 :
1009 : (defun ccl-dump-set-array (rrr cc)
1010 0 : (let ((rrr2 (logand cc 7))
1011 0 : (len (ash cc -3))
1012 : (i 0))
1013 0 : (insert (format "r%d = array[r%d] of length %d\n\t"
1014 0 : rrr rrr2 len))
1015 0 : (while (< i len)
1016 0 : (insert (format "%d " (ccl-get-next-code)))
1017 0 : (setq i (1+ i)))
1018 0 : (insert "\n")))
1019 :
1020 : (defun ccl-dump-jump (_ignore cc &optional address)
1021 0 : (insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
1022 0 : (if (>= cc 0)
1023 0 : (insert "+"))
1024 0 : (insert (format "%d)\n" (1+ cc))))
1025 :
1026 : (defun ccl-dump-jump-cond (rrr cc)
1027 0 : (insert (format "if (r%d == 0), " rrr))
1028 0 : (ccl-dump-jump nil cc))
1029 :
1030 : (defun ccl-dump-write-register-jump (rrr cc)
1031 0 : (insert (format "write r%d, " rrr))
1032 0 : (ccl-dump-jump nil cc))
1033 :
1034 : (defun ccl-dump-write-register-read-jump (rrr cc)
1035 0 : (insert (format "write r%d, read r%d, " rrr rrr))
1036 0 : (ccl-dump-jump nil cc)
1037 0 : (ccl-get-next-code) ; Skip dummy READ-JUMP
1038 : )
1039 :
1040 : (defun ccl-extract-arith-op (cc)
1041 0 : (aref ccl-arith-table (ash cc -6)))
1042 :
1043 : (defun ccl-dump-write-expr-const (_ignore cc)
1044 0 : (insert (format "write (r%d %s %d)\n"
1045 0 : (logand cc 7)
1046 0 : (ccl-extract-arith-op cc)
1047 0 : (ccl-get-next-code))))
1048 :
1049 : (defun ccl-dump-write-expr-register (_ignore cc)
1050 0 : (insert (format "write (r%d %s r%d)\n"
1051 0 : (logand cc 7)
1052 0 : (ccl-extract-arith-op cc)
1053 0 : (logand (ash cc -3) 7))))
1054 :
1055 : (defun ccl-dump-insert-char (cc)
1056 0 : (cond ((= cc ?\t) (insert " \"^I\""))
1057 0 : ((= cc ?\n) (insert " \"^J\""))
1058 0 : (t (insert (format " \"%c\"" cc)))))
1059 :
1060 : (defun ccl-dump-write-const-jump (_ignore cc)
1061 0 : (let ((address ccl-current-ic))
1062 0 : (insert "write char")
1063 0 : (ccl-dump-insert-char (ccl-get-next-code))
1064 0 : (insert ", ")
1065 0 : (ccl-dump-jump nil cc address)))
1066 :
1067 : (defun ccl-dump-write-const-read-jump (rrr cc)
1068 0 : (let ((address ccl-current-ic))
1069 0 : (insert "write char")
1070 0 : (ccl-dump-insert-char (ccl-get-next-code))
1071 0 : (insert (format ", read r%d, " rrr))
1072 0 : (ccl-dump-jump cc address)
1073 0 : (ccl-get-next-code) ; Skip dummy READ-JUMP
1074 0 : ))
1075 :
1076 : (defun ccl-dump-write-string-jump (_ignore cc)
1077 0 : (let ((address ccl-current-ic)
1078 0 : (len (ccl-get-next-code))
1079 : (i 0))
1080 0 : (insert "write \"")
1081 0 : (while (< i len)
1082 0 : (let ((code (ccl-get-next-code)))
1083 0 : (insert (ash code -16))
1084 0 : (if (< (1+ i) len) (insert (logand (ash code -8) 255)))
1085 0 : (if (< (+ i 2) len) (insert (logand code 255))))
1086 0 : (setq i (+ i 3)))
1087 0 : (insert "\", ")
1088 0 : (ccl-dump-jump nil cc address)))
1089 :
1090 : (defun ccl-dump-write-array-read-jump (rrr cc)
1091 0 : (let ((address ccl-current-ic)
1092 0 : (len (ccl-get-next-code))
1093 : (i 0))
1094 0 : (insert (format "write array[r%d] of length %d,\n\t" rrr len))
1095 0 : (while (< i len)
1096 0 : (ccl-dump-insert-char (ccl-get-next-code))
1097 0 : (setq i (1+ i)))
1098 0 : (insert (format "\n\tthen read r%d, " rrr))
1099 0 : (ccl-dump-jump nil cc address)
1100 0 : (ccl-get-next-code) ; Skip dummy READ-JUMP.
1101 0 : ))
1102 :
1103 : (defun ccl-dump-read-jump (rrr cc)
1104 0 : (insert (format "read r%d, " rrr))
1105 0 : (ccl-dump-jump nil cc))
1106 :
1107 : (defun ccl-dump-branch (rrr len)
1108 0 : (let ((jump-table-head ccl-current-ic)
1109 : (i 0))
1110 0 : (insert (format "jump to array[r%d] of length %d\n\t" rrr len))
1111 0 : (while (<= i len)
1112 0 : (insert (format "%d " (+ jump-table-head (ccl-get-next-code))))
1113 0 : (setq i (1+ i)))
1114 0 : (insert "\n")))
1115 :
1116 : (defun ccl-dump-read-register (rrr cc)
1117 0 : (insert (format "read r%d (%d remaining)\n" rrr cc)))
1118 :
1119 : (defun ccl-dump-read-branch (rrr len)
1120 0 : (insert (format "read r%d, " rrr))
1121 0 : (ccl-dump-branch rrr len))
1122 :
1123 : (defun ccl-dump-write-register (rrr cc)
1124 0 : (insert (format "write r%d (%d remaining)\n" rrr cc)))
1125 :
1126 : (defun ccl-dump-call (_ignore _cc)
1127 0 : (let ((subroutine (car (ccl-get-next-code))))
1128 0 : (insert (format-message "call subroutine `%s'\n" subroutine))))
1129 :
1130 : (defun ccl-dump-write-const-string (rrr cc)
1131 0 : (if (= rrr 0)
1132 0 : (progn
1133 0 : (insert "write char")
1134 0 : (ccl-dump-insert-char cc)
1135 0 : (newline))
1136 0 : (let ((len cc)
1137 : (i 0))
1138 0 : (insert "write \"")
1139 0 : (while (< i len)
1140 0 : (let ((code (ccl-get-next-code)))
1141 0 : (if (/= (logand code #x1000000) 0)
1142 0 : (progn
1143 0 : (insert (logand code #xFFFFFF))
1144 0 : (setq i (1+ i)))
1145 0 : (insert (format "%c" (lsh code -16)))
1146 0 : (if (< (1+ i) len)
1147 0 : (insert (format "%c" (logand (lsh code -8) 255))))
1148 0 : (if (< (+ i 2) len)
1149 0 : (insert (format "%c" (logand code 255))))
1150 0 : (setq i (+ i 3)))))
1151 0 : (insert "\"\n"))))
1152 :
1153 : (defun ccl-dump-write-array (rrr cc)
1154 0 : (let ((i 0))
1155 0 : (insert (format "write array[r%d] of length %d\n\t" rrr cc))
1156 0 : (while (< i cc)
1157 0 : (ccl-dump-insert-char (ccl-get-next-code))
1158 0 : (setq i (1+ i)))
1159 0 : (insert "\n")))
1160 :
1161 : (defun ccl-dump-end (&rest _ignore)
1162 0 : (insert "end\n"))
1163 :
1164 : (defun ccl-dump-set-assign-expr-const (rrr cc)
1165 0 : (insert (format "r%d %s= %d\n"
1166 0 : rrr
1167 0 : (ccl-extract-arith-op cc)
1168 0 : (ccl-get-next-code))))
1169 :
1170 : (defun ccl-dump-set-assign-expr-register (rrr cc)
1171 0 : (insert (format "r%d %s= r%d\n"
1172 0 : rrr
1173 0 : (ccl-extract-arith-op cc)
1174 0 : (logand cc 7))))
1175 :
1176 : (defun ccl-dump-set-expr-const (rrr cc)
1177 0 : (insert (format "r%d = r%d %s %d\n"
1178 0 : rrr
1179 0 : (logand cc 7)
1180 0 : (ccl-extract-arith-op cc)
1181 0 : (ccl-get-next-code))))
1182 :
1183 : (defun ccl-dump-set-expr-register (rrr cc)
1184 0 : (insert (format "r%d = r%d %s r%d\n"
1185 0 : rrr
1186 0 : (logand cc 7)
1187 0 : (ccl-extract-arith-op cc)
1188 0 : (logand (ash cc -3) 7))))
1189 :
1190 : (defun ccl-dump-jump-cond-expr-const (rrr cc)
1191 0 : (let ((address ccl-current-ic))
1192 0 : (insert (format "if !(r%d %s %d), "
1193 0 : rrr
1194 0 : (aref ccl-arith-table (ccl-get-next-code))
1195 0 : (ccl-get-next-code)))
1196 0 : (ccl-dump-jump nil cc address)))
1197 :
1198 : (defun ccl-dump-jump-cond-expr-register (rrr cc)
1199 0 : (let ((address ccl-current-ic))
1200 0 : (insert (format "if !(r%d %s r%d), "
1201 0 : rrr
1202 0 : (aref ccl-arith-table (ccl-get-next-code))
1203 0 : (ccl-get-next-code)))
1204 0 : (ccl-dump-jump nil cc address)))
1205 :
1206 : (defun ccl-dump-read-jump-cond-expr-const (rrr cc)
1207 0 : (insert (format "read r%d, " rrr))
1208 0 : (ccl-dump-jump-cond-expr-const rrr cc))
1209 :
1210 : (defun ccl-dump-read-jump-cond-expr-register (rrr cc)
1211 0 : (insert (format "read r%d, " rrr))
1212 0 : (ccl-dump-jump-cond-expr-register rrr cc))
1213 :
1214 : (defun ccl-dump-binary (code)
1215 0 : (let* ((ccl-code code)
1216 0 : (len (length ccl-code))
1217 : (i 2))
1218 0 : (while (< i len)
1219 0 : (let ((code (aref ccl-code i))
1220 : (j 27))
1221 0 : (while (>= j 0)
1222 0 : (insert (if (= (logand code (ash 1 j)) 0) ?0 ?1))
1223 0 : (setq j (1- j)))
1224 0 : (setq code (logand code 31))
1225 0 : (if (< code (length ccl-code-table))
1226 0 : (insert (format ":%s" (aref ccl-code-table code))))
1227 0 : (insert "\n"))
1228 0 : (setq i (1+ i)))))
1229 :
1230 : (defun ccl-dump-ex-cmd (rrr cc)
1231 0 : (let* ((RRR (logand cc ?\x7))
1232 0 : (Rrr (logand (ash cc -3) ?\x7))
1233 0 : (ex-op (aref ccl-extended-code-table (logand (ash cc -6) ?\x3fff))))
1234 0 : (insert (format "<%s> " ex-op))
1235 0 : (funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
1236 :
1237 : (defun ccl-dump-read-multibyte-character (rrr RRR _Rrr)
1238 0 : (insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
1239 :
1240 : (defun ccl-dump-write-multibyte-character (rrr RRR _Rrr)
1241 0 : (insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
1242 :
1243 : (defun ccl-dump-translate-character (rrr RRR Rrr)
1244 0 : (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
1245 :
1246 : (defun ccl-dump-translate-character-const-tbl (rrr RRR _Rrr)
1247 0 : (let ((tbl (ccl-get-next-code)))
1248 0 : (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
1249 :
1250 : (defun ccl-dump-lookup-int-const-tbl (rrr RRR _Rrr)
1251 0 : (let ((tbl (ccl-get-next-code)))
1252 0 : (insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
1253 :
1254 : (defun ccl-dump-lookup-char-const-tbl (rrr RRR _Rrr)
1255 0 : (let ((tbl (ccl-get-next-code)))
1256 0 : (insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
1257 :
1258 : (defun ccl-dump-iterate-multiple-map (rrr RRR _Rrr)
1259 0 : (let ((notbl (ccl-get-next-code))
1260 : (i 0) id)
1261 0 : (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
1262 0 : (insert (format "\tnumber of maps is %d .\n\t [" notbl))
1263 0 : (while (< i notbl)
1264 0 : (setq id (ccl-get-next-code))
1265 0 : (insert (format "%S" id))
1266 0 : (setq i (1+ i)))
1267 0 : (insert "]\n")))
1268 :
1269 : (defun ccl-dump-map-multiple (rrr RRR _Rrr)
1270 0 : (let ((notbl (ccl-get-next-code))
1271 : (i 0) id)
1272 0 : (insert (format "map-multiple r%d r%d\n" RRR rrr))
1273 0 : (insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
1274 0 : (while (< i notbl)
1275 0 : (setq id (ccl-get-next-code))
1276 0 : (if (= id -1)
1277 0 : (insert "]\n\t [")
1278 0 : (insert (format "%S " id)))
1279 0 : (setq i (1+ i)))
1280 0 : (insert "]\n")))
1281 :
1282 : (defun ccl-dump-map-single (rrr RRR _Rrr)
1283 0 : (let ((id (ccl-get-next-code)))
1284 0 : (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
1285 :
1286 :
1287 : ;; CCL emulation staffs
1288 :
1289 : ;; Not yet implemented.
1290 :
1291 : ;; Auto-loaded functions.
1292 :
1293 : ;;;###autoload
1294 : (defmacro declare-ccl-program (name &optional vector)
1295 : "Declare NAME as a name of CCL program.
1296 :
1297 : This macro exists for backward compatibility. In the old version of
1298 : Emacs, to compile a CCL program which calls another CCL program not
1299 : yet defined, it must be declared as a CCL program in advance. But,
1300 : now CCL program names are resolved not at compile time but before
1301 : execution.
1302 :
1303 : Optional arg VECTOR is a compiled CCL code of the CCL program."
1304 0 : `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
1305 :
1306 : ;;;###autoload
1307 : (defmacro define-ccl-program (name ccl-program &optional doc)
1308 : "Set NAME the compiled code of CCL-PROGRAM.
1309 :
1310 : CCL-PROGRAM has this form:
1311 : (BUFFER_MAGNIFICATION
1312 : CCL_MAIN_CODE
1313 : [ CCL_EOF_CODE ])
1314 :
1315 : BUFFER_MAGNIFICATION is an integer value specifying the approximate
1316 : output buffer magnification size compared with the bytes of input data
1317 : text. It is assured that the actual output buffer has 256 bytes
1318 : more than the size calculated by BUFFER_MAGNIFICATION.
1319 : If the value is zero, the CCL program can't execute `read' and
1320 : `write' commands.
1321 :
1322 : CCL_MAIN_CODE and CCL_EOF_CODE are CCL program codes. CCL_MAIN_CODE
1323 : executed at first. If there's no more input data when `read' command
1324 : is executed in CCL_MAIN_CODE, CCL_EOF_CODE is executed. If
1325 : CCL_MAIN_CODE is terminated, CCL_EOF_CODE is not executed.
1326 :
1327 : Here's the syntax of CCL program code in BNF notation. The lines
1328 : starting by two semicolons (and optional leading spaces) describe the
1329 : semantics.
1330 :
1331 : CCL_MAIN_CODE := CCL_BLOCK
1332 :
1333 : CCL_EOF_CODE := CCL_BLOCK
1334 :
1335 : CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...])
1336 :
1337 : STATEMENT :=
1338 : SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
1339 : | TRANSLATE | MAP | LOOKUP | END
1340 :
1341 : SET := (REG = EXPRESSION)
1342 : | (REG ASSIGNMENT_OPERATOR EXPRESSION)
1343 : ;; The following form is the same as (r0 = integer).
1344 : | integer
1345 :
1346 : EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
1347 :
1348 : ;; Evaluate EXPRESSION. If the result is nonzero, execute
1349 : ;; CCL_BLOCK_0. Otherwise, execute CCL_BLOCK_1.
1350 : IF := (if EXPRESSION CCL_BLOCK_0 CCL_BLOCK_1)
1351 :
1352 : ;; Evaluate EXPRESSION. Provided that the result is N, execute
1353 : ;; CCL_BLOCK_N.
1354 : BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...])
1355 :
1356 : ;; Execute STATEMENTs until (break) or (end) is executed.
1357 :
1358 : ;; Create a block of STATEMENTs for repeating. The STATEMENTs
1359 : ;; are executed sequentially until REPEAT or BREAK is executed.
1360 : ;; If REPEAT statement is executed, STATEMENTs are executed from the
1361 : ;; start again. If BREAK statements is executed, the execution
1362 : ;; exits from the block. If neither REPEAT nor BREAK is
1363 : ;; executed, the execution exits from the block after executing the
1364 : ;; last STATEMENT.
1365 : LOOP := (loop STATEMENT [STATEMENT ...])
1366 :
1367 : ;; Terminate the most inner loop.
1368 : BREAK := (break)
1369 :
1370 : REPEAT :=
1371 : ;; Jump to the head of the most inner loop.
1372 : (repeat)
1373 : ;; Same as: ((write [REG | integer | string])
1374 : ;; (repeat))
1375 : | (write-repeat [REG | integer | string])
1376 : ;; Same as: ((write REG [ARRAY])
1377 : ;; (read REG)
1378 : ;; (repeat))
1379 : | (write-read-repeat REG [ARRAY])
1380 : ;; Same as: ((write integer)
1381 : ;; (read REG)
1382 : ;; (repeat))
1383 : | (write-read-repeat REG integer)
1384 :
1385 : READ := ;; Set REG_0 to a byte read from the input text, set REG_1
1386 : ;; to the next byte read, and so on.
1387 : (read REG_0 [REG_1 ...])
1388 : ;; Same as: ((read REG)
1389 : ;; (if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1))
1390 : | (read-if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1)
1391 : ;; Same as: ((read REG)
1392 : ;; (branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...]))
1393 : | (read-branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...])
1394 : ;; Read a character from the input text while parsing
1395 : ;; multibyte representation, set REG_0 to the charset ID of
1396 : ;; the character, set REG_1 to the code point of the
1397 : ;; character. If the dimension of charset is two, set REG_1
1398 : ;; to ((CODE0 << 7) | CODE1), where CODE0 is the first code
1399 : ;; point and CODE1 is the second code point.
1400 : | (read-multibyte-character REG_0 REG_1)
1401 :
1402 : WRITE :=
1403 : ;; Write REG_0, REG_1, ... to the output buffer. If REG_N is
1404 : ;; a multibyte character, write the corresponding multibyte
1405 : ;; representation.
1406 : (write REG_0 [REG_1 ...])
1407 : ;; Same as: ((r7 = EXPRESSION)
1408 : ;; (write r7))
1409 : | (write EXPRESSION)
1410 : ;; Write the value of `integer' to the output buffer. If it
1411 : ;; is a multibyte character, write the corresponding multibyte
1412 : ;; representation.
1413 : | (write integer)
1414 : ;; Write the byte sequence of `string' as is to the output
1415 : ;; buffer.
1416 : | (write string)
1417 : ;; Same as: (write string)
1418 : | string
1419 : ;; Provided that the value of REG is N, write Nth element of
1420 : ;; ARRAY to the output buffer. If it is a multibyte
1421 : ;; character, write the corresponding multibyte
1422 : ;; representation.
1423 : | (write REG ARRAY)
1424 : ;; Write a multibyte representation of a character whose
1425 : ;; charset ID is REG_0 and code point is REG_1. If the
1426 : ;; dimension of the charset is two, REG_1 should be ((CODE0 <<
1427 : ;; 7) | CODE1), where CODE0 is the first code point and CODE1
1428 : ;; is the second code point of the character.
1429 : | (write-multibyte-character REG_0 REG_1)
1430 :
1431 : ;; Call CCL program whose name is ccl-program-name.
1432 : CALL := (call ccl-program-name)
1433 :
1434 : ;; Terminate the CCL program.
1435 : END := (end)
1436 :
1437 : ;; CCL registers that can contain any integer value. As r7 is also
1438 : ;; used by CCL interpreter, its value is changed unexpectedly.
1439 : REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
1440 :
1441 : ARG := REG | integer
1442 :
1443 : OPERATOR :=
1444 : ;; Normal arithmetic operators (same meaning as C code).
1445 : + | - | * | / | %
1446 :
1447 : ;; Bitwise operators (same meaning as C code)
1448 : | & | `|' | ^
1449 :
1450 : ;; Shifting operators (same meaning as C code)
1451 : | << | >>
1452 :
1453 : ;; (REG = ARG_0 <8 ARG_1) means:
1454 : ;; (REG = ((ARG_0 << 8) | ARG_1))
1455 : | <8
1456 :
1457 : ;; (REG = ARG_0 >8 ARG_1) means:
1458 : ;; ((REG = (ARG_0 >> 8))
1459 : ;; (r7 = (ARG_0 & 255)))
1460 : | >8
1461 :
1462 : ;; (REG = ARG_0 // ARG_1) means:
1463 : ;; ((REG = (ARG_0 / ARG_1))
1464 : ;; (r7 = (ARG_0 % ARG_1)))
1465 : | //
1466 :
1467 : ;; Normal comparing operators (same meaning as C code)
1468 : | < | > | == | <= | >= | !=
1469 :
1470 : ;; If ARG_0 and ARG_1 are higher and lower byte of Shift-JIS
1471 : ;; code, and CHAR is the corresponding JISX0208 character,
1472 : ;; (REG = ARG_0 de-sjis ARG_1) means:
1473 : ;; ((REG = CODE0)
1474 : ;; (r7 = CODE1))
1475 : ;; where CODE0 is the first code point of CHAR, CODE1 is the
1476 : ;; second code point of CHAR.
1477 : | de-sjis
1478 :
1479 : ;; If ARG_0 and ARG_1 are the first and second code point of
1480 : ;; JISX0208 character CHAR, and SJIS is the corresponding
1481 : ;; Shift-JIS code,
1482 : ;; (REG = ARG_0 en-sjis ARG_1) means:
1483 : ;; ((REG = HIGH)
1484 : ;; (r7 = LOW))
1485 : ;; where HIGH is the higher byte of SJIS, LOW is the lower
1486 : ;; byte of SJIS.
1487 : | en-sjis
1488 :
1489 : ASSIGNMENT_OPERATOR :=
1490 : ;; Same meaning as C code
1491 : += | -= | *= | /= | %= | &= | `|=' | ^= | <<= | >>=
1492 :
1493 : ;; (REG <8= ARG) is the same as:
1494 : ;; ((REG <<= 8)
1495 : ;; (REG |= ARG))
1496 : | <8=
1497 :
1498 : ;; (REG >8= ARG) is the same as:
1499 : ;; ((r7 = (REG & 255))
1500 : ;; (REG >>= 8))
1501 :
1502 : ;; (REG //= ARG) is the same as:
1503 : ;; ((r7 = (REG % ARG))
1504 : ;; (REG /= ARG))
1505 : | //=
1506 :
1507 : ARRAY := `[' integer ... `]'
1508 :
1509 :
1510 : TRANSLATE :=
1511 : ;; Decode character SRC, translate it by translate table
1512 : ;; TABLE, and encode it back to DST. TABLE is specified
1513 : ;; by its id number in REG_0, SRC is specified by its
1514 : ;; charset id number and codepoint in REG_1 and REG_2
1515 : ;; respectively.
1516 : ;; On encoding, the charset of highest priority is selected.
1517 : ;; After the execution, DST is specified by its charset
1518 : ;; id number and codepoint in REG_1 and REG_2 respectively.
1519 : (translate-character REG_0 REG_1 REG_2)
1520 :
1521 : ;; Same as above except for SYMBOL specifying the name of
1522 : ;; the translate table defined by `define-translation-table'.
1523 : | (translate-character SYMBOL REG_1 REG_2)
1524 :
1525 : LOOKUP :=
1526 : ;; Look up character SRC in hash table TABLE. TABLE is
1527 : ;; specified by its name in SYMBOL, and SRC is specified by
1528 : ;; its charset id number and codepoint in REG_1 and REG_2
1529 : ;; respectively.
1530 : ;; If its associated value is an integer, set REG_1 to that
1531 : ;; value, and set r7 to 1. Otherwise, set r7 to 0.
1532 : (lookup-character SYMBOL REG_1 REG_2)
1533 :
1534 : ;; Look up integer value N in hash table TABLE. TABLE is
1535 : ;; specified by its name in SYMBOL and N is specified in
1536 : ;; REG.
1537 : ;; If its associated value is a character, set REG to that
1538 : ;; value, and set r7 to 1. Otherwise, set r7 to 0.
1539 : | (lookup-integer SYMBOL REG(integer))
1540 :
1541 : MAP :=
1542 : ;; The following statements are for internal use only.
1543 : (iterate-multiple-map REG REG MAP-IDs)
1544 : | (map-multiple REG REG (MAP-SET))
1545 : | (map-single REG REG MAP-ID)
1546 :
1547 : MAP-IDs := MAP-ID ...
1548 : MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET
1549 : MAP-ID := integer
1550 : "
1551 : (declare (doc-string 3))
1552 0 : `(let ((prog ,(unwind-protect
1553 0 : (progn
1554 : ;; To make ,(charset-id CHARSET) works well.
1555 0 : (fset 'charset-id 'charset-id-internal)
1556 0 : (ccl-compile (eval ccl-program)))
1557 0 : (fmakunbound 'charset-id))))
1558 0 : (defconst ,name prog ,doc)
1559 0 : (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
1560 0 : nil))
1561 :
1562 : ;;;###autoload
1563 : (defmacro check-ccl-program (ccl-program &optional name)
1564 : "Check validity of CCL-PROGRAM.
1565 : If CCL-PROGRAM is a symbol denoting a CCL program, return
1566 : CCL-PROGRAM, else return nil.
1567 : If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
1568 : register CCL-PROGRAM by name NAME, and return NAME."
1569 0 : `(if (ccl-program-p ,ccl-program)
1570 0 : (if (vectorp ,ccl-program)
1571 : (progn
1572 0 : (register-ccl-program ,name ,ccl-program)
1573 0 : ,name)
1574 0 : ,ccl-program)))
1575 :
1576 : ;;;###autoload
1577 : (defun ccl-execute-with-args (ccl-prog &rest args)
1578 : "Execute CCL-PROGRAM with registers initialized by the remaining args.
1579 : The return value is a vector of resulting CCL registers.
1580 :
1581 : See the documentation of `define-ccl-program' for the detail of CCL program."
1582 0 : (let ((reg (make-vector 8 0))
1583 : (i 0))
1584 0 : (while (and args (< i 8))
1585 0 : (if (not (integerp (car args)))
1586 0 : (error "Arguments should be integer"))
1587 0 : (aset reg i (car args))
1588 0 : (setq args (cdr args) i (1+ i)))
1589 0 : (ccl-execute ccl-prog reg)
1590 0 : reg))
1591 :
1592 : (provide 'ccl)
1593 :
1594 : ;;; ccl.el ends here
|