lisp/international/ccl.el

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