LCOV - code coverage report
Current view: top level - lisp/international - ccl.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 0 720 0.0 %
Date: 2017-08-27 09:44:50 Functions: 0 92 0.0 %

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

Generated by: LCOV version 1.12