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