Sync up CCL engine on XEmacs with Emacs21.

Hello. I've been working for synchronizing XEmacs CCL engine with that of Emacs 21. Now I finished it, and attach patches and ChangeLogs to this mail. (I am one of the developpers on Emacs, and worked on its CCL engine.) The CCL engine of XEmacs 21.2.36 have many bugs because its CCL engine is originated from Emacs 20.2. In the current version of Emacs, all of the known bugs have been fixed. An important change that is visible from Emacs Lisp is how to specify CCL program itself. Now we should use a symbol, which have been registered with a ccl_program vector, to specify the CCL program. It it because GC may move the vector after CCL program registration, thus redisplay engine may not be able to find out the specified CCL program (fortunately, the current version of GC does not compact vectors, thus it dose not cause the problem). This change, however, does not break backward compatibility, because all APIs called from Emacs Lisp accept a bare vector as a CCL program as well as a symbol. Of course, set-charset-ccl-program also accepts a vector, but if you specify a vector, the abobe problem cannot be resolved. (font-ccl-encoder-alist of Emacs 21.0 also accepts a vector even now.) If XEmacs developpers accept this patch, I will send a patch in order to use a symbol instead of a vector for lisp/mule/*.el in XEmacs. P.S. Against my wish, I cannot help disabling CCL_TranslateCharacter* instructions because XEmacs has no translation table. Even if a ccl program use these instructions, CCL interpreter will do nothing. P.P.S. I found a bug of read-multibyte-character on XEmacs 21.2.36. The patch will also fix this problem. FYI, you can reproduce it by the following code. (define-ccl-program test-ccl '(1 (read-multibyte-character r0 r1) (write-multibyte-character r0 r1))) (ccl-execute-on-string 'test-ccl [0 0 0 0 0 0 0 0 0] "今") -> "#" (If you give another character to write-multibyte-character, it may crash XEmacs.) Here is a ChangeLog in lisp directory. 2000-10-05 MIYASHITA Hisashi <himi(a)m17n.org&gt; * mule/mule-ccl.el: Sync up with Emacs 21.0.90. (ccl-compile): Apply integerp, not integer-or-char-p to check the type of the buffer magnification (ccl-compile-write-string): Encode a string with binary coding system. (ccl-compile-write-repeat): Likewise. And here is a ChangeLog in src directory. 2000-10-05 MIYASHITA Hisashi <himi(a)m17n.org&gt; * mule-ccl.c: Sync up with Emacs 21.0.90. (ccl_driver)<CCL_TranslateCharacter>: Disabled. Do nothing. (ccl_driver)<CCL_TranslateCharacterConstTbl>: Likewise. (ccl_driver[WriteMultibyteChar2]): Bug fix. Use MAX_LEADING_BYTE_OFFICIAL_2 instead of MIN_LEADING_BYTE_OFFICIAL_2 to check whether the leading char belongs to official 2-dimensional charset. (CCL_WRITE_CHAR): When CCL_MODE_ENCODING, write the given character as is. Otherwise, if it is a multibyte char, convert it by non_ascii_set_charptr_emchar, then write it. (CCL_WRITE_STRING): Likewise. (ccl_get_compiled_code): New function. (setup_ccl_program): When ccl_prog is invalid, return -1. (Fregister_code_conversion_map): New function. (syms_of_mule_ccl): defsubr Fregister_code_conversion_map. * mule-ccl.h: Sync up with Emacs 21.0.90. (Fregister_ccl_program): export it. * redisplay-msw.c (separate_textual_runs): If ccl program is not valid, don't do ccl conversion. * redisplay-x.c (separate_textual_runs): Ditto. * file-coding.c (Fmake_coding_system): When type is ccl and value is vector, register it with a proper symbol. And checks whether the given ccl program is valid. (mule_decode): When calling ccl_driver, if src indicates NULL pointer, set an empty string instead. (mule_encode): Likewise. This is a patch to sync up CCL engine. Index: lisp/mule/mule-ccl.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/lisp/mule/mule-ccl.el,v retrieving revision 1.4.2.4 diff -c -r1.4.2.4 mule-ccl.el *** mule-ccl.el 2000/09/11 09:57:36 1.4.2.4 --- mule-ccl.el 2000/10/05 15:19:24 *************** *** 22,28 **** ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ! ;; Synched up with: FSF 20.2 ;;; Commentary: --- 22,28 ---- ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ! ;; Synched up with: FSF 21.0.90 ;;; Commentary: *************** *** 39,104 **** ;; combination of three or more arithmetic operations can be ;; calculated faster than Emacs Lisp. ;; ! ;; Here's the syntax of CCL program in BNF notation. ! ;; ! ;; CCL_PROGRAM := ! ;; (BUFFER_MAGNIFICATION ! ;; CCL_MAIN_BLOCK ! ;; [ CCL_EOF_BLOCK ]) ! ;; ! ;; BUFFER_MAGNIFICATION := integer ! ;; CCL_MAIN_BLOCK := CCL_BLOCK ! ;; CCL_EOF_BLOCK := CCL_BLOCK ! ;; ! ;; CCL_BLOCK := ! ;; STATEMENT | (STATEMENT [STATEMENT ...]) ! ;; STATEMENT := ! ;; SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL ! ;; ! ;; SET := ! ;; (REG = EXPRESSION) ! ;; | (REG ASSIGNMENT_OPERATOR EXPRESSION) ! ;; | integer ! ;; ! ;; EXPRESSION := ARG | (EXPRESSION OPERATOR ARG) ! ;; ! ;; IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK) ! ;; BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...]) ! ;; LOOP := (loop STATEMENT [STATEMENT ...]) ! ;; BREAK := (break) ! ;; REPEAT := ! ;; (repeat) ! ;; | (write-repeat [REG | integer | string]) ! ;; | (write-read-repeat REG [integer | ARRAY]) ! ;; READ := ! ;; (read REG ...) ! ;; | (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK) ! ;; | (read-branch REG CCL_BLOCK [CCL_BLOCK ...]) ! ;; | (read-multibyte-character REG {charset} REG {code-point}) ! ;; WRITE := ! ;; (write REG ...) ! ;; | (write EXPRESSION) ! ;; | (write integer) | (write string) | (write REG ARRAY) ! ;; | string ! ;; | (write-multibyte-character REG(charset) REG(codepoint)) ! ;; CALL := (call ccl-program-name) ! ;; END := (end) ! ;; ! ;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 ! ;; ARG := REG | integer ! ;; OPERATOR := ! ;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // ! ;; | < | > | == | <= | >= | != | de-sjis | en-sjis ! ;; ASSIGNMENT_OPERATOR := ! ;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= ! ;; ARRAY := '[' integer ... ']' ;;; Code: (defconst ccl-command-table [if branch loop break repeat write-repeat write-read-repeat read read-if read-branch write call end ! read-multibyte-character write-multibyte-character] "Vector of CCL commands (symbols).") ;; Put a property to each symbol of CCL commands for the compiler. --- 39,55 ---- ;; combination of three or more arithmetic operations can be ;; calculated faster than Emacs Lisp. ;; ! ;; Syntax and semantics of CCL program is described in the ! ;; documentation of `define-ccl-program'. ;;; Code: (defconst ccl-command-table [if branch loop break repeat write-repeat write-read-repeat read read-if read-branch write call end ! read-multibyte-character write-multibyte-character ! translate-character ! iterate-multiple-map map-multiple map-single] "Vector of CCL commands (symbols).") ;; Put a property to each symbol of CCL commands for the compiler. *************** *** 228,238 **** ;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and ;; increment it. If IC is specified, embed DATA at IC. (defun ccl-embed-data (data &optional ic) ! (let ((val (if (characterp data) (char-int data) data))) ! (if ic ! (aset ccl-program-vector ic val) ! (aset ccl-program-vector ccl-current-ic val) ! (setq ccl-current-ic (1+ ccl-current-ic))))) ;; Embed string STR of length LEN in `ccl-program-vector' at ;; `ccl-current-ic'. --- 179,204 ---- ;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and ;; increment it. If IC is specified, embed DATA at IC. (defun ccl-embed-data (data &optional ic) ! (if (characterp data) ! (setq data (char-int data))) ! (if ic ! (aset ccl-program-vector ic data) ! (let ((len (length ccl-program-vector))) ! (if (>= ccl-current-ic len) ! (let ((new (make-vector (* len 2) nil))) ! (while (> len 0) ! (setq len (1- len)) ! (aset new len (aref ccl-program-vector len))) ! (setq ccl-program-vector new)))) ! (aset ccl-program-vector ccl-current-ic data) ! (setq ccl-current-ic (1+ ccl-current-ic)))) ! ! ;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give ! ;; proper index number for SYMBOL. PROP should be ! ;; `translation-table-id', `code-conversion-map-id', or ! ;; `ccl-program-idx'. ! (defun ccl-embed-symbol (symbol prop) ! (ccl-embed-data (cons symbol prop))) ;; Embed string STR of length LEN in `ccl-program-vector' at ;; `ccl-current-ic'. *************** *** 280,287 **** (logior (ash (get reg2 'ccl-register-number) 8) (ash data 11)) (ash data 8))))) ! (aset ccl-program-vector ccl-current-ic code) ! (setq ccl-current-ic (1+ ccl-current-ic)))) ;; extended ccl command format ;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -| --- 246,252 ---- (logior (ash (get reg2 'ccl-register-number) 8) (ash data 11)) (ash data 8))))) ! (ccl-embed-data code))) ;; extended ccl command format ;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -| *************** *** 297,314 **** (defun ccl-increment-ic (inc) (setq ccl-current-ic (+ ccl-current-ic inc))) - ;;;###autoload - (defun ccl-program-p (obj) - "Return t if OBJECT is a valid CCL compiled code." - (and (vectorp obj) - (let ((i 0) (len (length obj)) (flag t)) - (if (> len 1) - (progn - (while (and flag (< i len)) - (setq flag (integerp (aref obj i))) - (setq i (1+ i))) - flag))))) - ;; If non-nil, index of the start of the current loop. (defvar ccl-loop-head nil) ;; If non-nil, list of absolute addresses of the breaking points of --- 262,267 ---- *************** *** 319,325 **** (defun ccl-compile (ccl-program) "Return a compiled code of CCL-PROGRAM as a vector of integer." (if (or (null (consp ccl-program)) ! (null (integer-or-char-p (car ccl-program))) (null (listp (car (cdr ccl-program))))) (error "CCL: Invalid CCL program: %s" ccl-program)) (if (null (vectorp ccl-program-vector)) --- 272,278 ---- (defun ccl-compile (ccl-program) "Return a compiled code of CCL-PROGRAM as a vector of integer." (if (or (null (consp ccl-program)) ! (null (integerp (car ccl-program))) (null (listp (car (cdr ccl-program))))) (error "CCL: Invalid CCL program: %s" ccl-program)) (if (null (vectorp ccl-program-vector)) *************** *** 479,485 **** (setq left 'r7))) ;; Now EXPR has the form (LEFT OP RIGHT). ! (if (eq rrr left) ;; Compile this SET statement as `(RRR OP= RIGHT)'. (if (integer-or-char-p right) (progn --- 432,439 ---- (setq left 'r7))) ;; Now EXPR has the form (LEFT OP RIGHT). ! (if (and (eq rrr left) ! (< op (length ccl-assign-arith-table))) ;; Compile this SET statement as `(RRR OP= RIGHT)'. (if (integer-or-char-p right) (progn *************** *** 501,506 **** --- 455,461 ---- ;; Compile WRITE statement with string argument. (defun ccl-compile-write-string (str) + (setq str (encode-coding-string str 'binary)) (let ((len (length str))) (ccl-embed-code 'write-const-string 1 len) (ccl-embed-string len str)) *************** *** 712,717 **** --- 667,673 ---- (ccl-embed-code 'write-const-jump 0 ccl-loop-head) (ccl-embed-data arg)) ((stringp arg) + (setq arg (encode-coding-string arg 'binary)) (let ((len (length arg)) (i 0)) (ccl-embed-code 'write-string-jump 0 ccl-loop-head) *************** *** 825,835 **** (error "CCL: Invalid number of arguments: %s" cmd)) (if (not (symbolp (nth 1 cmd))) (error "CCL: Subroutine should be a symbol: %s" cmd)) ! (let* ((name (nth 1 cmd)) ! (idx (get name 'ccl-program-idx))) ! (if (not idx) ! (error "CCL: Unknown subroutine name: %s" name)) ! (ccl-embed-code 'call 0 idx)) nil) ;; Compile END statement. --- 781,788 ---- (error "CCL: Invalid number of arguments: %s" cmd)) (if (not (symbolp (nth 1 cmd))) (error "CCL: Subroutine should be a symbol: %s" cmd)) ! (ccl-embed-code 'call 1 0) ! (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx) nil) ;; Compile END statement. *************** *** 862,958 **** nil) ;; Compile translate-character ! ;; (defun ccl-compile-translate-character (cmd) ! ;; (if (/= (length cmd) 4) ! ;; (error "CCL: Invalid number of arguments: %s" cmd)) ! ;; (let ((Rrr (nth 1 cmd)) ! ;; (RRR (nth 2 cmd)) ! ;; (rrr (nth 3 cmd))) ! ;; (ccl-check-register rrr cmd) ! ;; (ccl-check-register RRR cmd) ! ;; (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number))) ! ;; (if (not (get Rrr 'translation-table)) ! ;; (error "CCL: Invalid translation table %s in %s" Rrr cmd)) ! ;; (ccl-embed-extended-command 'translate-character-const-tbl ! ;; rrr RRR 0) ! ;; (ccl-embed-data Rrr)) ! ;; (t ! ;; (ccl-check-register Rrr cmd) ! ;; (ccl-embed-extended-command 'translate-character rrr RRR Rrr)))) ! ;; nil) ! ! ;; (defun ccl-compile-iterate-multiple-map (cmd) ! ;; (ccl-compile-multiple-map-function 'iterate-multiple-map cmd) ! ;; nil) ! ! ;; (defun ccl-compile-map-multiple (cmd) ! ;; (if (/= (length cmd) 4) ! ;; (error "CCL: Invalid number of arguments: %s" cmd)) ! ;; (let ((func '(lambda (arg mp) ! ;; (let ((len 0) result add) ! ;; (while arg ! ;; (if (consp (car arg)) ! ;; (setq add (funcall func (car arg) t) ! ;; result (append result add) ! ;; add (+ (-(car add)) 1)) ! ;; (setq result ! ;; (append result ! ;; (list (car arg))) ! ;; add 1)) ! ;; (setq arg (cdr arg) ! ;; len (+ len add))) ! ;; (if mp ! ;; (cons (- len) result) ! ;; result)))) ! ;; arg) ! ;; (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd)) ! ;; (funcall func (nth 3 cmd) nil))) ! ;; (ccl-compile-multiple-map-function 'map-multiple arg)) ! ;; nil) ! ! ;; (defun ccl-compile-map-single (cmd) ! ;; (if (/= (length cmd) 4) ! ;; (error "CCL: Invalid number of arguments: %s" cmd)) ! ;; (let ((RRR (nth 1 cmd)) ! ;; (rrr (nth 2 cmd)) ! ;; (map (nth 3 cmd)) ! ;; id) ! ;; (ccl-check-register rrr cmd) ! ;; (ccl-check-register RRR cmd) ! ;; (ccl-embed-extended-command 'map-single rrr RRR 0) ! ;; (cond ((symbolp map) ! ;; (if (get map 'code-conversion-map) ! ;; (ccl-embed-data map) ! ;; (error "CCL: Invalid map: %s" map))) ! ;; (t ! ;; (error "CCL: Invalid type of arguments: %s" cmd)))) ! ;; nil) ! ! ;; (defun ccl-compile-multiple-map-function (command cmd) ! ;; (if (< (length cmd) 4) ! ;; (error "CCL: Invalid number of arguments: %s" cmd)) ! ;; (let ((RRR (nth 1 cmd)) ! ;; (rrr (nth 2 cmd)) ! ;; (args (nthcdr 3 cmd)) ! ;; map) ! ;; (ccl-check-register rrr cmd) ! ;; (ccl-check-register RRR cmd) ! ;; (ccl-embed-extended-command command rrr RRR 0) ! ;; (ccl-embed-data (length args)) ! ;; (while args ! ;; (setq map (car args)) ! ;; (cond ((symbolp map) ! ;; (if (get map 'code-conversion-map) ! ;; (ccl-embed-data map) ! ;; (error "CCL: Invalid map: %s" map))) ! ;; ((numberp map) ! ;; (ccl-embed-data map)) ! ;; (t ! ;; (error "CCL: Invalid type of arguments: %s" cmd))) ! ;; (setq args (cdr args)))))  ! ;;; CCL dump stuff ;;;###autoload (defun ccl-dump (ccl-code) --- 815,913 ---- nil) ;; Compile translate-character ! (defun ccl-compile-translate-character (cmd) ! (if (/= (length cmd) 4) ! (error "CCL: Invalid number of arguments: %s" cmd)) ! (let ((Rrr (nth 1 cmd)) ! (RRR (nth 2 cmd)) ! (rrr (nth 3 cmd))) ! (ccl-check-register rrr cmd) ! (ccl-check-register RRR cmd) ! (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number))) ! (ccl-embed-extended-command 'translate-character-const-tbl ! rrr RRR 0) ! (ccl-embed-symbol Rrr 'translation-table-id)) ! (t ! (ccl-check-register Rrr cmd) ! (ccl-embed-extended-command 'translate-character rrr RRR Rrr)))) ! nil) ! ! (defun ccl-compile-iterate-multiple-map (cmd) ! (ccl-compile-multiple-map-function 'iterate-multiple-map cmd) ! nil) ! ! (defun ccl-compile-map-multiple (cmd) ! (if (/= (length cmd) 4) ! (error "CCL: Invalid number of arguments: %s" cmd)) ! (let (func arg) ! (setq func ! (lambda (arg mp) ! (let ((len 0) result add) ! (while arg ! (if (consp (car arg)) ! (setq add (funcall func (car arg) t) ! result (append result add) ! add (+ (- (car add)) 1)) ! (setq result ! (append result ! (list (car arg))) ! add 1)) ! (setq arg (cdr arg) ! len (+ len add))) ! (if mp ! (cons (- len) result) ! result)))) ! (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd)) ! (funcall func (nth 3 cmd) nil))) ! (ccl-compile-multiple-map-function 'map-multiple arg)) ! nil) + (defun ccl-compile-map-single (cmd) + (if (/= (length cmd) 4) + (error "CCL: Invalid number of arguments: %s" cmd)) + (let ((RRR (nth 1 cmd)) + (rrr (nth 2 cmd)) + (map (nth 3 cmd)) + id) + (ccl-check-register rrr cmd) + (ccl-check-register RRR cmd) + (ccl-embed-extended-command 'map-single rrr RRR 0) + (cond ((symbolp map) + (if (get map 'code-conversion-map) + (ccl-embed-symbol map 'code-conversion-map-id) + (error "CCL: Invalid map: %s" map))) + (t + (error "CCL: Invalid type of arguments: %s" cmd)))) + nil) + + (defun ccl-compile-multiple-map-function (command cmd) + (if (< (length cmd) 4) + (error "CCL: Invalid number of arguments: %s" cmd)) + (let ((RRR (nth 1 cmd)) + (rrr (nth 2 cmd)) + (args (nthcdr 3 cmd)) + map) + (ccl-check-register rrr cmd) + (ccl-check-register RRR cmd) + (ccl-embed-extended-command command rrr RRR 0) + (ccl-embed-data (length args)) + (while args + (setq map (car args)) + (cond ((symbolp map) + (if (get map 'code-conversion-map) + (ccl-embed-symbol map 'code-conversion-map-id) + (error "CCL: Invalid map: %s" map))) + ((numberp map) + (ccl-embed-data map)) + (t + (error "CCL: Invalid type of arguments: %s" cmd))) + (setq args (cdr args))))) +  ! ;;; CCL dump staffs ! ! ;; To avoid byte-compiler warning. ! (defvar ccl-code) ;;;###autoload (defun ccl-dump (ccl-code) *************** *** 980,986 **** ;; Return a CCL code in `ccl-code' at `ccl-current-ic'. (defun ccl-get-next-code () - (declare (special ccl-code)) (prog1 (aref ccl-code ccl-current-ic) (setq ccl-current-ic (1+ ccl-current-ic)))) --- 935,940 ---- *************** *** 1229,1269 **** (defun ccl-dump-write-multibyte-character (rrr RRR Rrr) (insert (format "write-multibyte-character r%d r%d\n" RRR rrr))) ! ;; (defun ccl-dump-translate-character (rrr RRR Rrr) ! ;; (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr))) ! ;; (defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr) ! ;; (let ((tbl (ccl-get-next-code))) ! ;; (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr)))) ! ! ;; (defun ccl-dump-iterate-multiple-map (rrr RRR Rrr) ! ;; (let ((notbl (ccl-get-next-code)) ! ;; (i 0) id) ! ;; (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr)) ! ;; (insert (format "\tnumber of maps is %d .\n\t [" notbl)) ! ;; (while (< i notbl) ! ;; (setq id (ccl-get-next-code)) ! ;; (insert (format "%S" id)) ! ;; (setq i (1+ i))) ! ;; (insert "]\n"))) ! ! ;; (defun ccl-dump-map-multiple (rrr RRR Rrr) ! ;; (let ((notbl (ccl-get-next-code)) ! ;; (i 0) id) ! ;; (insert (format "map-multiple r%d r%d\n" RRR rrr)) ! ;; (insert (format "\tnumber of maps and separators is %d\n\t [" notbl)) ! ;; (while (< i notbl) ! ;; (setq id (ccl-get-next-code)) ! ;; (if (= id -1) ! ;; (insert "]\n\t [") ! ;; (insert (format "%S " id))) ! ;; (setq i (1+ i))) ! ;; (insert "]\n"))) ! ! ;; (defun ccl-dump-map-single (rrr RRR Rrr) ! ;; (let ((id (ccl-get-next-code))) ! ;; (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))  ;; CCL emulation staffs --- 1183,1223 ---- (defun ccl-dump-write-multibyte-character (rrr RRR Rrr) (insert (format "write-multibyte-character r%d r%d\n" RRR rrr))) + + (defun ccl-dump-translate-character (rrr RRR Rrr) + (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr))) + + (defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr) + (let ((tbl (ccl-get-next-code))) + (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr)))) + + (defun ccl-dump-iterate-multiple-map (rrr RRR Rrr) + (let ((notbl (ccl-get-next-code)) + (i 0) id) + (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr)) + (insert (format "\tnumber of maps is %d .\n\t [" notbl)) + (while (< i notbl) + (setq id (ccl-get-next-code)) + (insert (format "%S" id)) + (setq i (1+ i))) + (insert "]\n"))) ! (defun ccl-dump-map-multiple (rrr RRR Rrr) ! (let ((notbl (ccl-get-next-code)) ! (i 0) id) ! (insert (format "map-multiple r%d r%d\n" RRR rrr)) ! (insert (format "\tnumber of maps and separators is %d\n\t [" notbl)) ! (while (< i notbl) ! (setq id (ccl-get-next-code)) ! (if (= id -1) ! (insert "]\n\t [") ! (insert (format "%S " id))) ! (setq i (1+ i))) ! (insert "]\n"))) ! (defun ccl-dump-map-single (rrr RRR Rrr) ! (let ((id (ccl-get-next-code))) ! (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))  ;; CCL emulation staffs *************** *** 1275,1291 **** ;;;###autoload (defmacro declare-ccl-program (name &optional vector) "Declare NAME as a name of CCL program. - To compile a CCL program which calls another CCL program not yet - defined, it must be declared as a CCL program in advance. Optional arg VECTOR is a compiled CCL code of the CCL program." `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector))) ;;;###autoload (defmacro define-ccl-program (name ccl-program &optional doc) "Set NAME the compiled code of CCL-PROGRAM. ! CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'. ! The compiled code is a vector of integers." `(let ((prog ,(ccl-compile (eval ccl-program)))) (defconst ,name prog ,doc) (put ',name 'ccl-program-idx (register-ccl-program ',name prog)) --- 1229,1451 ---- ;;;###autoload (defmacro declare-ccl-program (name &optional vector) "Declare NAME as a name of CCL program. + + This macro exists for backward compatibility. In the old version of + Emacs, to compile a CCL program which calls another CCL program not + yet defined, it must be declared as a CCL program in advance. But, + now CCL program names are resolved not at compile time but before + execution. Optional arg VECTOR is a compiled CCL code of the CCL program." `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector))) ;;;###autoload (defmacro define-ccl-program (name ccl-program &optional doc) "Set NAME the compiled code of CCL-PROGRAM. ! ! CCL-PROGRAM is has this form: ! (BUFFER_MAGNIFICATION ! CCL_MAIN_CODE ! [ CCL_EOF_CODE ]) ! ! BUFFER_MAGNIFICATION is an integer value specifying the approximate ! output buffer magnification size compared with the bytes of input data ! text. If the value is zero, the CCL program can't execute `read' and ! `write' commands. ! ! CCL_MAIN_CODE and CCL_EOF_CODE are CCL program codes. CCL_MAIN_CODE ! executed at first. If there's no more input data when `read' command ! is executed in CCL_MAIN_CODE, CCL_EOF_CODE is executed. If ! CCL_MAIN_CODE is terminated, CCL_EOF_CODE is not executed. ! ! Here's the syntax of CCL program code in BNF notation. The lines ! starting by two semicolons (and optional leading spaces) describe the ! semantics. ! ! CCL_MAIN_CODE := CCL_BLOCK ! ! CCL_EOF_CODE := CCL_BLOCK ! ! CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...]) ! ! STATEMENT := ! SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL ! | TRANSLATE | END ! ! SET := (REG = EXPRESSION) ! | (REG ASSIGNMENT_OPERATOR EXPRESSION) ! ;; The following form is the same as (r0 = integer). ! | integer ! ! EXPRESSION := ARG | (EXPRESSION OPERATOR ARG) ! ! ;; Evaluate EXPRESSION. If the result is nonzeor, execute ! ;; CCL_BLOCK_0. Otherwise, execute CCL_BLOCK_1. ! IF := (if EXPRESSION CCL_BLOCK_0 CCL_BLOCK_1) ! ! ;; Evaluate EXPRESSION. Provided that the result is N, execute ! ;; CCL_BLOCK_N. ! BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...]) ! ! ;; Execute STATEMENTs until (break) or (end) is executed. ! LOOP := (loop STATEMENT [STATEMENT ...]) ! ! ;; Terminate the most inner loop. ! BREAK := (break) ! ! REPEAT := ! ;; Jump to the head of the most inner loop. ! (repeat) ! ;; Same as: ((write [REG | integer | string]) ! ;; (repeat)) ! | (write-repeat [REG | integer | string]) ! ;; Same as: ((write REG [ARRAY]) ! ;; (read REG) ! ;; (repeat)) ! | (write-read-repeat REG [ARRAY]) ! ;; Same as: ((write integer) ! ;; (read REG) ! ;; (repeat)) ! | (write-read-repeat REG integer) ! ! READ := ;; Set REG_0 to a byte read from the input text, set REG_1 ! ;; to the next byte read, and so on. ! (read REG_0 [REG_1 ...]) ! ;; Same as: ((read REG) ! ;; (if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1)) ! | (read-if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1) ! ;; Same as: ((read REG) ! ;; (branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...])) ! | (read-branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...]) ! ;; Read a character from the input text while parsing ! ;; multibyte representation, set REG_0 to the charset ID of ! ;; the character, set REG_1 to the code point of the ! ;; character. If the dimension of charset is two, set REG_1 ! ;; to ((CODE0 << 8) | CODE1), where CODE0 is the first code ! ;; point and CODE1 is the second code point. ! | (read-multibyte-character REG_0 REG_1) ! ! WRITE := ! ;; Write REG_0, REG_1, ... to the output buffer. If REG_N is ! ;; a multibyte character, write the corresponding multibyte ! ;; representation. ! (write REG_0 [REG_1 ...]) ! ;; Same as: ((r7 = EXPRESSION) ! ;; (write r7)) ! | (write EXPRESSION) ! ;; Write the value of `integer' to the output buffer. If it ! ;; is a multibyte character, write the corresponding multibyte ! ;; representation. ! | (write integer) ! ;; Write the byte sequence of `string' as is to the output ! ;; buffer. It is encoded by binary coding system, thus, ! ;; by this operation, you cannot write multibyte string ! ;; as it is. ! | (write string) ! ;; Same as: (write string) ! | string ! ;; Provided that the value of REG is N, write Nth element of ! ;; ARRAY to the output buffer. If it is a multibyte ! ;; character, write the corresponding multibyte ! ;; representation. ! | (write REG ARRAY) ! ;; Write a multibyte representation of a character whose ! ;; charset ID is REG_0 and code point is REG_1. If the ! ;; dimension of the charset is two, REG_1 should be ((CODE0 << ! ;; 8) | CODE1), where CODE0 is the first code point and CODE1 ! ;; is the second code point of the character. ! | (write-multibyte-character REG_0 REG_1) ! ! ;; Call CCL program whose name is ccl-program-name. ! CALL := (call ccl-program-name) ! ! ;; Terminate the CCL program. ! END := (end) ! ! ;; CCL registers that can contain any integer value. As r7 is also ! ;; used by CCL interpreter, its value is changed unexpectedly. ! REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 ! ! ARG := REG | integer ! ! OPERATOR := ! ;; Normal arithmethic operators (same meaning as C code). ! + | - | * | / | % ! ! ;; Bitwize operators (same meaning as C code) ! | & | `|' | ^ ! ! ;; Shifting operators (same meaning as C code) ! | << | >> ! ! ;; (REG = ARG_0 <8 ARG_1) means: ! ;; (REG = ((ARG_0 << 8) | ARG_1)) ! | <8 ! ! ;; (REG = ARG_0 >8 ARG_1) means: ! ;; ((REG = (ARG_0 >> 8)) ! ;; (r7 = (ARG_0 & 255))) ! | >8 ! ! ;; (REG = ARG_0 // ARG_1) means: ! ;; ((REG = (ARG_0 / ARG_1)) ! ;; (r7 = (ARG_0 % ARG_1))) ! | // ! ! ;; Normal comparing operators (same meaning as C code) ! | < | > | == | <= | >= | != ! ! ;; If ARG_0 and ARG_1 are higher and lower byte of Shift-JIS ! ;; code, and CHAR is the corresponding JISX0208 character, ! ;; (REG = ARG_0 de-sjis ARG_1) means: ! ;; ((REG = CODE0) ! ;; (r7 = CODE1)) ! ;; where CODE0 is the first code point of CHAR, CODE1 is the ! ;; second code point of CHAR. ! | de-sjis ! ! ;; If ARG_0 and ARG_1 are the first and second code point of ! ;; JISX0208 character CHAR, and SJIS is the correponding ! ;; Shift-JIS code, ! ;; (REG = ARG_0 en-sjis ARG_1) means: ! ;; ((REG = HIGH) ! ;; (r7 = LOW)) ! ;; where HIGH is the higher byte of SJIS, LOW is the lower ! ;; byte of SJIS. ! | en-sjis ! ! ASSIGNMENT_OPERATOR := ! ;; Same meaning as C code ! += | -= | *= | /= | %= | &= | `|=' | ^= | <<= | >>= ! ! ;; (REG <8= ARG) is the same as: ! ;; ((REG <<= 8) ! ;; (REG |= ARG)) ! | <8= ! ! ;; (REG >8= ARG) is the same as: ! ;; ((r7 = (REG & 255)) ! ;; (REG >>= 8)) ! ! ;; (REG //= ARG) is the same as: ! ;; ((r7 = (REG % ARG)) ! ;; (REG /= ARG)) ! | //= ! ! ARRAY := `[' integer ... `]' ! ! ! TRANSLATE := ! (translate-character REG(table) REG(charset) REG(codepoint)) ! | (translate-character SYMBOL REG(charset) REG(codepoint)) ! MAP := ! (iterate-multiple-map REG REG MAP-IDs) ! | (map-multiple REG REG (MAP-SET)) ! | (map-single REG REG MAP-ID) ! MAP-IDs := MAP-ID ... ! MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET ! MAP-ID := integer ! " `(let ((prog ,(ccl-compile (eval ccl-program)))) (defconst ,name prog ,doc) (put ',name 'ccl-program-idx (register-ccl-program ',name prog)) *************** *** 1294,1318 **** ;;;###autoload (defmacro check-ccl-program (ccl-program &optional name) "Check validity of CCL-PROGRAM. ! If CCL-PROGRAM is a symbol denoting a valid CCL program, return CCL-PROGRAM, else return nil. If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied, register CCL-PROGRAM by name NAME, and return NAME." ! `(let ((result ,ccl-program)) ! (cond ((symbolp ,ccl-program) ! (or (numberp (get ,ccl-program 'ccl-program-idx)) ! (setq result nil))) ! ((vectorp ,ccl-program) ! (setq result ,name) ! (register-ccl-program result ,ccl-program)) ! (t ! (setq result nil))) ! result)) ;;;###autoload (defun ccl-execute-with-args (ccl-prog &rest args) "Execute CCL-PROGRAM with registers initialized by the remaining args. ! The return value is a vector of resulting CCL registers." (let ((reg (make-vector 8 0)) (i 0)) (while (and args (< i 8)) --- 1454,1476 ---- ;;;###autoload (defmacro check-ccl-program (ccl-program &optional name) "Check validity of CCL-PROGRAM. ! If CCL-PROGRAM is a symbol denoting a CCL program, return CCL-PROGRAM, else return nil. If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied, register CCL-PROGRAM by name NAME, and return NAME." ! `(if (ccl-program-p ,ccl-program) ! (if (vectorp ,ccl-program) ! (progn ! (register-ccl-program ,name ,ccl-program) ! ,name) ! ,ccl-program))) ;;;###autoload (defun ccl-execute-with-args (ccl-prog &rest args) "Execute CCL-PROGRAM with registers initialized by the remaining args. ! The return value is a vector of resulting CCL registers. ! ! See the documentation of `define-ccl-program' for the detail of CCL program." (let ((reg (make-vector 8 0)) (i 0)) (while (and args (< i 8)) Index: src/file-coding.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/file-coding.c,v retrieving revision 1.7.2.44 diff -c -r1.7.2.44 file-coding.c *** file-coding.c 2000/09/16 12:11:31 1.7.2.44 --- file-coding.c 2000/10/05 15:19:48 *************** *** 983,1000 **** } else if (EQ (type, Qccl)) { if (EQ (key, Qdecode)) ! { ! CHECK_VECTOR (value); ! CODING_SYSTEM_CCL_DECODE (codesys) = value; ! } else if (EQ (key, Qencode)) { ! CHECK_VECTOR (value); ! CODING_SYSTEM_CCL_ENCODE (codesys) = value; } else ! signal_simple_error ("Unrecognized property", key); } #endif /* MULE */ else --- 983,1024 ---- } else if (EQ (type, Qccl)) { + Lisp_Object sym; + struct ccl_program test_ccl; + unsigned char *suffix; + + /* Check key first. */ if (EQ (key, Qdecode)) ! suffix = "-ccl-decode"; else if (EQ (key, Qencode)) + suffix = "-ccl-encode"; + else + signal_simple_error ("Unrecognized property", key); + + /* If value is vector, register it as a ccl program + associated with an newly created symbol for + backward compatibility. */ + if (VECTORP (value)) { ! sym = Fintern (concat2 (Fsymbol_name (name), ! build_string (suffix)), ! Qnil); ! Fregister_ccl_program (sym, value); } else ! { ! CHECK_SYMBOL (value); ! sym = value; ! } ! /* check if the given ccl programs are valid. */ ! if (setup_ccl_program (&test_ccl, sym) < 0) ! signal_simple_error ("Invalid CCL program", value); ! ! if (EQ (key, Qdecode)) ! CODING_SYSTEM_CCL_DECODE (codesys) = sym; ! else if (EQ (key, Qencode)) ! CODING_SYSTEM_CCL_ENCODE (codesys) = sym; ! } #endif /* MULE */ else *************** *** 2431,2437 **** break; case CODESYS_CCL: str->ccl.last_block = str->flags & CODING_STATE_END; ! ccl_driver (&str->ccl, src, dst, n, 0, CCL_MODE_DECODING); break; case CODESYS_ISO2022: decode_coding_iso2022 (decoding, src, dst, n); --- 2455,2464 ---- break; case CODESYS_CCL: str->ccl.last_block = str->flags & CODING_STATE_END; ! /* When applying ccl program to stream, MUST NOT set NULL ! pointer to src. */ ! ccl_driver (&str->ccl, ((src) ? src : (unsigned char*)""), ! dst, n, 0, CCL_MODE_DECODING); break; case CODESYS_ISO2022: decode_coding_iso2022 (decoding, src, dst, n); *************** *** 2843,2849 **** break; case CODESYS_CCL: str->ccl.last_block = str->flags & CODING_STATE_END; ! ccl_driver (&str->ccl, src, dst, n, 0, CCL_MODE_ENCODING); break; case CODESYS_ISO2022: encode_coding_iso2022 (encoding, src, dst, n); --- 2870,2879 ---- break; case CODESYS_CCL: str->ccl.last_block = str->flags & CODING_STATE_END; ! /* When applying ccl program to stream, MUST NOT set NULL ! pointer to src. */ ! ccl_driver (&str->ccl, ((src) ? src : (unsigned char*)""), ! dst, n, 0, CCL_MODE_ENCODING); break; case CODESYS_ISO2022: encode_coding_iso2022 (encoding, src, dst, n); Index: src/mule-ccl.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/mule-ccl.c,v retrieving revision 1.13.2.13 diff -c -r1.13.2.13 mule-ccl.c *** mule-ccl.c 2000/09/20 02:38:21 1.13.2.13 --- mule-ccl.c 2000/10/05 15:19:56 *************** *** 1,8 **** /* CCL (Code Conversion Language) interpreter. ! Copyright (C) 1995, 1997, 1998, 1999 Electrotechnical Laboratory, JAPAN. Licensed to the Free Software Foundation. ! This file is part of XEmacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by --- 1,8 ---- /* CCL (Code Conversion Language) interpreter. ! Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN. Licensed to the Free Software Foundation. ! This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by *************** *** 19,37 **** the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ ! /* Synched up with : FSF Emacs 20.3.10 without ExCCL ! * (including {Read|Write}MultibyteChar) */ #ifdef emacs - #include <config.h> - - #if 0 - #ifdef STDC_HEADERS - #include <stdlib.h> #endif - #endif #include "lisp.h" #include "buffer.h" #include "mule-charset.h" --- 19,34 ---- the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ ! /* Synched up with : FSF Emacs 21.0.90 except TranslateCharacter */ #ifdef emacs #include <config.h> #endif + #include <stdio.h> + + #ifdef emacs + #include "lisp.h" #include "buffer.h" #include "mule-charset.h" *************** *** 40,54 **** #else /* not emacs */ - #include <stdio.h> #include "mulelib.h" #endif /* not emacs */ /* This contains all code conversion map available to CCL. */ - /* Lisp_Object Vcode_conversion_map_vector; - */ /* Alist of fontname patterns vs corresponding CCL program. */ Lisp_Object Vfont_ccl_encoder_alist; --- 37,48 ---- *************** *** 59,74 **** /* These symbols are properties which associate with code conversion map and their ID respectively. */ - /* Lisp_Object Qcode_conversion_map; Lisp_Object Qcode_conversion_map_id; - */ /* Symbols of ccl program have this property, a value of the property is an index for Vccl_protram_table. */ Lisp_Object Qccl_program_idx; ! /* Vector of CCL program names vs corresponding program data. */ Lisp_Object Vccl_program_table; /* CCL (Code Conversion Language) is a simple language which has --- 53,70 ---- /* These symbols are properties which associate with code conversion map and their ID respectively. */ Lisp_Object Qcode_conversion_map; Lisp_Object Qcode_conversion_map_id; /* Symbols of ccl program have this property, a value of the property is an index for Vccl_protram_table. */ Lisp_Object Qccl_program_idx; ! /* Table of registered CCL programs. Each element is a vector of ! NAME, CCL_PROG, and RESOLVEDP where NAME (symbol) is the name of ! the program, CCL_PROG (vector) is the compiled code of the program, ! RESOLVEDP (t or nil) is the flag to tell if symbols in CCL_PROG is ! already resolved to index numbers or not. */ Lisp_Object Vccl_program_table; /* CCL (Code Conversion Language) is a simple language which has *************** *** 181,198 **** #define CCL_WriteConstJump 0x08 /* Write constant and jump: 1:A--D--D--R--E--S--S-000XXXXX ! 2:const ------------------------------ ! write (const); IC += ADDRESS; */ #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump: 1:A--D--D--R--E--S--S-rrrXXXXX ! 2:const 3:A--D--D--R--E--S--S-rrrYYYYY ----------------------------- ! write (const); IC += 2; read (reg[rrr]); IC += ADDRESS; --- 177,194 ---- #define CCL_WriteConstJump 0x08 /* Write constant and jump: 1:A--D--D--R--E--S--S-000XXXXX ! 2:CONST ------------------------------ ! write (CONST); IC += ADDRESS; */ #define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump: 1:A--D--D--R--E--S--S-rrrXXXXX ! 2:CONST 3:A--D--D--R--E--S--S-rrrYYYYY ----------------------------- ! write (CONST); IC += 2; read (reg[rrr]); IC += ADDRESS; *************** *** 300,309 **** */ #define CCL_Call 0x13 /* Call the CCL program whose ID is ! (CC..C). ! 1:CCCCCCCCCCCCCCCCCCCC000XXXXX ! ------------------------------ ! call (CC..C) */ #define CCL_WriteConstString 0x14 /* Write a constant or a string: --- 296,310 ---- */ #define CCL_Call 0x13 /* Call the CCL program whose ID is ! CC..C or cc..c. ! 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX ! [2:00000000cccccccccccccccccccc] ! ------------------------------ ! if (FFF) ! call (cc..c) ! IC++; ! else ! call (CC..C) */ #define CCL_WriteConstString 0x14 /* Write a constant or a string: *************** *** 422,428 **** IC += 2; */ ! #define CCL_Extension 0x1F /* Extended CCL code 1:ExtendedCOMMNDRrrRRRrrrXXXXX 2:ARGUEMENT 3:... --- 423,429 ---- IC += 2; */ ! #define CCL_Extention 0x1F /* Extended CCL code 1:ExtendedCOMMNDRrrRRRrrrXXXXX 2:ARGUEMENT 3:... *************** *** 430,436 **** extended_command (rrr,RRR,Rrr,ARGS) */ ! /* Here after, Extended CCL Instructions. Bit length of extended command is 14. Therefore, the instruction code range is 0..16384(0x3fff). --- 431,437 ---- extended_command (rrr,RRR,Rrr,ARGS) */ ! /* Here after, Extended CCL Instructions. Bit length of extended command is 14. Therefore, the instruction code range is 0..16384(0x3fff). *************** *** 450,456 **** #define CCL_WriteMultibyteChar2 0x01 /* Write Multibyte Character 1:ExtendedCOMMNDRrrRRRrrrXXXXX */ - #if 0 /* Translate a character whose code point is reg[rrr] and the charset ID is reg[RRR] by a translation table whose ID is reg[Rrr]. --- 451,456 ---- *************** *** 489,495 **** 3:MAP-ID1 4:MAP-ID2 ... ! */ /* Map the code in reg[rrr] by MAPs starting from the Nth (N = reg[RRR]) map. --- 489,495 ---- 3:MAP-ID1 4:MAP-ID2 ... ! */ /* Map the code in reg[rrr] by MAPs starting from the Nth (N = reg[RRR]) map. *************** *** 540,546 **** At first, VAL0 is set to reg[rrr], and it is translated by the first map to VAL1. Then, VAL1 is translated by the next map to VAL2. This mapping is iterated until the last map is used. The ! result of the mapping is the last value of VAL?. But, when VALm is mapped to VALn and VALn is not a number, the mapping proceed as below: --- 540,549 ---- At first, VAL0 is set to reg[rrr], and it is translated by the first map to VAL1. Then, VAL1 is translated by the next map to VAL2. This mapping is iterated until the last map is used. The ! result of the mapping is the last value of VAL?. When the mapping ! process reached to the end of the map set, it moves to the next ! map set. If the next does not exit, the mapping process terminates, ! and regard the last value as a result. But, when VALm is mapped to VALn and VALn is not a number, the mapping proceed as below: *************** *** 550,558 **** In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm proceed to the next map. ! If VALn is lambda, the whole mapping process terminates, and VALm ! is the result of this mapping. Each map is a Lisp vector of the following format (a) or (b): (a)......[STARTPOINT VAL1 VAL2 ...] --- 553,565 ---- In VALn is t, VALm is reverted to reg[rrr] and the mapping of VALm proceed to the next map. + + If VALn is lambda, move to the next map set like reaching to the + end of the current map set. ! If VALn is a symbol, call the CCL program refered by it. ! Then, use reg[rrr] as a mapped value except for -1, -2 and -3. ! Such special values are regarded as nil, t, and lambda respectively. Each map is a Lisp vector of the following format (a) or (b): (a)......[STARTPOINT VAL1 VAL2 ...] *************** *** 560,566 **** where STARTPOINT is an offset to be used for indexing a map, ENDPOINT is a maximum index number of a map, ! VAL and VALn is a number, nil, t, or lambda. Valid index range of a map of type (a) is: STARTPOINT <= index < STARTPOINT + map_size - 1 --- 567,573 ---- where STARTPOINT is an offset to be used for indexing a map, ENDPOINT is a maximum index number of a map, ! VAL and VALn is a number, nil, t, or lambda. Valid index range of a map of type (a) is: STARTPOINT <= index < STARTPOINT + map_size - 1 *************** *** 580,586 **** N:SEPARATOR_z (< 0) */ ! #define MAX_MAP_SET_LEVEL 20 typedef struct { --- 587,593 ---- N:SEPARATOR_z (< 0) */ ! #define MAX_MAP_SET_LEVEL 30 typedef struct { *************** *** 590,611 **** static tr_stack mapping_stack[MAX_MAP_SET_LEVEL]; static tr_stack *mapping_stack_pointer; - #endif ! #define PUSH_MAPPING_STACK(restlen, orig) \ ! { \ ! mapping_stack_pointer->rest_length = (restlen); \ ! mapping_stack_pointer->orig_val = (orig); \ ! mapping_stack_pointer++; \ ! } ! #define POP_MAPPING_STACK(restlen, orig) \ ! { \ ! mapping_stack_pointer--; \ ! (restlen) = mapping_stack_pointer->rest_length; \ ! (orig) = mapping_stack_pointer->orig_val; \ ! } \ #define CCL_MapSingle 0x12 /* Map by single code conversion map 1:ExtendedCOMMNDXXXRRRrrrXXXXX 2:MAP-ID --- 597,642 ---- static tr_stack mapping_stack[MAX_MAP_SET_LEVEL]; static tr_stack *mapping_stack_pointer; ! /* If this variable is non-zero, it indicates the stack_idx ! of immediately called by CCL_MapMultiple. */ ! static int stack_idx_of_map_multiple = 0; ! ! #define PUSH_MAPPING_STACK(restlen, orig) \ ! do { \ ! mapping_stack_pointer->rest_length = (restlen); \ ! mapping_stack_pointer->orig_val = (orig); \ ! mapping_stack_pointer++; \ ! } while (0) ! #define POP_MAPPING_STACK(restlen, orig) \ ! do { \ ! mapping_stack_pointer--; \ ! (restlen) = mapping_stack_pointer->rest_length; \ ! (orig) = mapping_stack_pointer->orig_val; \ ! } while (0) + #define CCL_CALL_FOR_MAP_INSTRUCTION(symbol, ret_ic) \ + do { \ + struct ccl_program called_ccl; \ + if (stack_idx >= 256 \ + || (setup_ccl_program (&called_ccl, (symbol)) != 0)) \ + { \ + if (stack_idx > 0) \ + { \ + ccl_prog = ccl_prog_stack_struct[0].ccl_prog; \ + ic = ccl_prog_stack_struct[0].ic; \ + } \ + CCL_INVALID_CMD; \ + } \ + ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; \ + ccl_prog_stack_struct[stack_idx].ic = (ret_ic); \ + stack_idx++; \ + ccl_prog = called_ccl.prog; \ + ic = CCL_HEADER_MAIN; \ + goto ccl_repeat; \ + } while (0) + #define CCL_MapSingle 0x12 /* Map by single code conversion map 1:ExtendedCOMMNDXXXRRRrrrXXXXX 2:MAP-ID *************** *** 643,742 **** #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z)) r[7] = LOWER_BYTE (SJIS (Y, Z) */ /* Suspend CCL program because of reading from empty input buffer or writing to full output buffer. When this program is resumed, the ! same I/O command is executed. The `if (1)' is for warning suppression. */ #define CCL_SUSPEND(stat) \ do { \ ic--; \ ccl->status = stat; \ ! if (1) goto ccl_finish; \ } while (0) /* Terminate CCL program because of invalid command. Should not occur ! in the normal case. The `if (1)' is for warning suppression. */ #define CCL_INVALID_CMD \ do { \ ccl->status = CCL_STAT_INVALID_CMD; \ ! if (1) goto ccl_error_handler; \ } while (0) /* Encode one character CH to multibyte form and write to the current ! output buffer. If CH is less than 256, CH is written as is. */ ! #define CCL_WRITE_CHAR(ch) do { \ ! if (!destination) \ ! { \ ! ccl->status = CCL_STAT_INVALID_CMD; \ ! goto ccl_error_handler; \ ! } \ ! else \ ! { \ ! Bufbyte work[MAX_EMCHAR_LEN]; \ ! int len = ( ch < ( conversion_mode == CCL_MODE_ENCODING ? \ ! 256 : 128 ) ) ? \ ! simple_set_charptr_emchar (work, ch) : \ ! non_ascii_set_charptr_emchar (work, ch); \ ! Dynarr_add_many (destination, work, len); \ ! } \ ! } while (0) /* Write a string at ccl_prog[IC] of length LEN to the current output ! buffer. */ ! #define CCL_WRITE_STRING(len) do { \ ! if (!destination) \ ! { \ ! ccl->status = CCL_STAT_INVALID_CMD; \ ! goto ccl_error_handler; \ ! } \ ! else \ ! { \ ! Bufbyte work[MAX_EMCHAR_LEN]; \ ! for (i = 0; i < len; i++) \ ! { \ ! int ch = (XINT (ccl_prog[ic + (i / 3)]) \ ! >> ((2 - (i % 3)) * 8)) & 0xFF; \ ! int bytes = \ ! ( ch < ( conversion_mode == CCL_MODE_ENCODING ? \ ! 256 : 128 ) ) ? \ ! simple_set_charptr_emchar (work, ch) : \ ! non_ascii_set_charptr_emchar (work, ch); \ ! Dynarr_add_many (destination, work, bytes); \ ! } \ ! } \ ! } while (0) /* Read one byte from the current input buffer into Rth register. */ ! #define CCL_READ_CHAR(r) do { \ ! if (!src && !ccl->last_block) \ ! { \ ! ccl->status = CCL_STAT_INVALID_CMD; \ ! goto ccl_error_handler; \ ! } \ ! else if (src < src_end) \ ! r = *src++; \ ! else if (ccl->last_block) \ ! { \ ! ic = ccl->eof_ic; \ ! goto ccl_repeat; \ ! } \ ! else \ ! /* Suspend CCL program because of \ ! reading from empty input buffer or \ ! writing to full output buffer. \ ! When this program is resumed, the \ ! same I/O command is executed. */ \ ! { \ ! ic--; \ ! ccl->status = CCL_STAT_SUSPEND_BY_SRC; \ ! goto ccl_finish; \ ! } \ ! } while (0) /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting ! text goes to a place pointed by DESTINATION. The bytes actually ! processed is returned as *CONSUMED. The return value is the length ! of the resulting text. As a side effect, the contents of CCL registers are updated. If SOURCE or DESTINATION is NULL, only operations on registers are permitted. */ --- 674,865 ---- #define CCL_ENCODE_SJIS 0x17 /* X = HIGHER_BYTE (SJIS (Y, Z)) r[7] = LOWER_BYTE (SJIS (Y, Z) */ + /* Terminate CCL program successfully. */ + #define CCL_SUCCESS \ + do { \ + ccl->status = CCL_STAT_SUCCESS; \ + goto ccl_finish; \ + } while (0) + /* Suspend CCL program because of reading from empty input buffer or writing to full output buffer. When this program is resumed, the ! same I/O command is executed. */ #define CCL_SUSPEND(stat) \ do { \ ic--; \ ccl->status = stat; \ ! goto ccl_finish; \ } while (0) /* Terminate CCL program because of invalid command. Should not occur ! in the normal case. */ #define CCL_INVALID_CMD \ do { \ ccl->status = CCL_STAT_INVALID_CMD; \ ! goto ccl_error_handler; \ } while (0) /* Encode one character CH to multibyte form and write to the current ! output buffer. At encoding time, if CH is less than 256, CH is ! written as is. At decoding time, if CH cannot be regarded as an ! ASCII character, write it in multibyte form. */ ! #define CCL_WRITE_CHAR(ch) \ ! do { \ ! if (!destination) \ ! CCL_INVALID_CMD; \ ! if (conversion_mode == CCL_MODE_ENCODING) \ ! { \ ! if (ch == '\n') \ ! { \ ! if (ccl->eol_type == CCL_CODING_EOL_CRLF) \ ! { \ ! Dynarr_add (destination, '\r'); \ ! Dynarr_add (destination, '\n'); \ ! } \ ! else if (ccl->eol_type == CCL_CODING_EOL_CR) \ ! Dynarr_add (destination, '\r'); \ ! else \ ! Dynarr_add (destination, '\n'); \ ! } \ ! else if (ch < 0x100) \ ! { \ ! Dynarr_add (destination, ch); \ ! } \ ! else \ ! { \ ! Bufbyte work[MAX_EMCHAR_LEN]; \ ! int len; \ ! len = non_ascii_set_charptr_emchar (work, ch); \ ! Dynarr_add_many (destination, work, len); \ ! } \ ! } \ ! else \ ! { \ ! if (!CHAR_MULTIBYTE_P(ch)) \ ! { \ ! Dynarr_add (destination, ch); \ ! } \ ! else \ ! { \ ! Bufbyte work[MAX_EMCHAR_LEN]; \ ! int len; \ ! len = non_ascii_set_charptr_emchar (work, ch); \ ! Dynarr_add_many (destination, work, len); \ ! } \ ! } \ ! } while (0) /* Write a string at ccl_prog[IC] of length LEN to the current output ! buffer. But this macro treat this string as a binary. Therefore, ! cannot handle a multibyte string except for Control-1 characters. */ ! #define CCL_WRITE_STRING(len) \ ! do { \ ! Bufbyte work[MAX_EMCHAR_LEN]; \ ! int ch, bytes; \ ! if (!destination) \ ! CCL_INVALID_CMD; \ ! else if (conversion_mode == CCL_MODE_ENCODING) \ ! { \ ! for (i = 0; i < len; i++) \ ! { \ ! ch = ((XINT (ccl_prog[ic + (i / 3)])) \ ! >> ((2 - (i % 3)) * 8)) & 0xFF; \ ! if (ch == '\n') \ ! { \ ! if (ccl->eol_type == CCL_CODING_EOL_CRLF) \ ! { \ ! Dynarr_add (destination, '\r'); \ ! Dynarr_add (destination, '\n'); \ ! } \ ! else if (ccl->eol_type == CCL_CODING_EOL_CR) \ ! Dynarr_add (destination, '\r'); \ ! else \ ! Dynarr_add (destination, '\n'); \ ! } \ ! if (ch < 0x100) \ ! { \ ! Dynarr_add (destination, ch); \ ! } \ ! else \ ! { \ ! bytes = non_ascii_set_charptr_emchar (work, ch); \ ! Dynarr_add_many (destination, work, len); \ ! } \ ! } \ ! } \ ! else \ ! { \ ! for (i = 0; i < len; i++) \ ! { \ ! ch = ((XINT (ccl_prog[ic + (i / 3)])) \ ! >> ((2 - (i % 3)) * 8)) & 0xFF; \ ! if (!CHAR_MULTIBYTE_P(ch)) \ ! { \ ! Dynarr_add (destination, ch); \ ! } \ ! else \ ! { \ ! bytes = non_ascii_set_charptr_emchar (work, ch); \ ! Dynarr_add_many (destination, work, len); \ ! } \ ! } \ ! } \ ! } while (0) /* Read one byte from the current input buffer into Rth register. */ ! #define CCL_READ_CHAR(r) \ ! do { \ ! if (!src) \ ! CCL_INVALID_CMD; \ ! if (src < src_end) \ ! r = *src++; \ ! else \ ! { \ ! if (ccl->last_block) \ ! { \ ! ic = ccl->eof_ic; \ ! goto ccl_repeat; \ ! } \ ! else \ ! CCL_SUSPEND (CCL_STAT_SUSPEND_BY_SRC); \ ! } \ ! } while (0) + /* Set C to the character code made from CHARSET and CODE. This is + like MAKE_CHAR but check the validity of CHARSET and CODE. If they + are not valid, set C to (CODE & 0xFF) because that is usually the + case that CCL_ReadMultibyteChar2 read an invalid code and it set + CODE to that invalid byte. */ + + /* On XEmacs, TranslateCharacter is not supported. Thus, this + macro is not used. */ + #if 0 + #define CCL_MAKE_CHAR(charset, code, c) \ + do { \ + if (charset == CHARSET_ASCII) \ + c = code & 0xFF; \ + else if (CHARSET_DEFINED_P (charset) \ + && (code & 0x7F) >= 32 \ + && (code < 256 || ((code >> 7) & 0x7F) >= 32)) \ + { \ + int c1 = code & 0x7F, c2 = 0; \ + \ + if (code >= 256) \ + c2 = c1, c1 = (code >> 7) & 0x7F; \ + c = MAKE_CHAR (charset, c1, c2); \ + } \ + else \ + c = code & 0xFF; \ + } while (0) + #endif + + /* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting ! text goes to a place pointed by DESTINATION, the length of which ! should not exceed DST_BYTES. The bytes actually processed is ! returned as *CONSUMED. The return value is the length of the ! resulting text. As a side effect, the contents of CCL registers are updated. If SOURCE or DESTINATION is NULL, only operations on registers are permitted. */ *************** *** 752,772 **** int ic; /* Instruction Counter. */ }; ! /* For the moment, we only support depth 256 of stack. */ static struct ccl_prog_stack ccl_prog_stack_struct[256]; int ! ccl_driver (struct ccl_program *ccl, const unsigned char *source, ! unsigned_char_dynarr *destination, int src_bytes, ! int *consumed, int conversion_mode) { ! int *reg = ccl->reg; ! int ic = ccl->ic; ! int code = -1; /* init to illegal value, */ ! int field1, field2; ! Lisp_Object *ccl_prog = ccl->prog; const unsigned char *src = source, *src_end = src + src_bytes; ! int jump_address = 0; /* shut up the compiler */ int i, j, op; int stack_idx = ccl->stack_idx; /* Instruction counter of the current CCL code. */ --- 875,898 ---- int ic; /* Instruction Counter. */ }; ! /* For the moment, we only support depth 256 of stack. */ static struct ccl_prog_stack ccl_prog_stack_struct[256]; int ! ccl_driver (struct ccl_program *ccl, ! const unsigned char *source, ! unsigned_char_dynarr *destination, ! int src_bytes, ! int *consumed, ! int conversion_mode) { ! register int *reg = ccl->reg; ! register int ic = ccl->ic; ! register int code = -1; ! register int field1, field2; ! register Lisp_Object *ccl_prog = ccl->prog; const unsigned char *src = source, *src_end = src + src_bytes; ! int jump_address; int i, j, op; int stack_idx = ccl->stack_idx; /* Instruction counter of the current CCL code. */ *************** *** 775,785 **** if (ic >= ccl->eof_ic) ic = CCL_HEADER_MAIN; - #if 0 /* not for XEmacs ? */ if (ccl->buf_magnification ==0) /* We can't produce any bytes. */ ! dst = NULL; ! #endif #ifdef CCL_DEBUG ccl_backtrace_idx = 0; #endif --- 901,912 ---- if (ic >= ccl->eof_ic) ic = CCL_HEADER_MAIN; if (ccl->buf_magnification ==0) /* We can't produce any bytes. */ ! destination = NULL; + /* Set mapping stack pointer. */ + mapping_stack_pointer = mapping_stack; + #ifdef CCL_DEBUG ccl_backtrace_idx = 0; #endif *************** *** 927,933 **** i = reg[RRR]; j = XINT (ccl_prog[ic]); op = field1 >> 6; ! ic++; goto ccl_set_expr; case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */ --- 1054,1060 ---- i = reg[RRR]; j = XINT (ccl_prog[ic]); op = field1 >> 6; ! jump_address = ic + 1; goto ccl_set_expr; case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */ *************** *** 947,978 **** i = reg[RRR]; j = reg[Rrr]; op = field1 >> 6; goto ccl_set_expr; ! case CCL_Call: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */ { Lisp_Object slot; if (stack_idx >= 256 ! || field1 < 0 ! || field1 >= XVECTOR_LENGTH (Vccl_program_table) ! || (slot = XVECTOR_DATA (Vccl_program_table)[field1], ! !CONSP (slot)) ! || !VECTORP (XCDR (slot))) { if (stack_idx > 0) { ccl_prog = ccl_prog_stack_struct[0].ccl_prog; ic = ccl_prog_stack_struct[0].ic; } ! ccl->status = CCL_STAT_INVALID_CMD; ! goto ccl_error_handler; } ! ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; ccl_prog_stack_struct[stack_idx].ic = ic; stack_idx++; ! ccl_prog = XVECTOR_DATA (XCDR (slot)); ic = CCL_HEADER_MAIN; } break; --- 1074,1116 ---- i = reg[RRR]; j = reg[Rrr]; op = field1 >> 6; + jump_address = ic; goto ccl_set_expr; ! case CCL_Call: /* 1:CCCCCCCCCCCCCCCCCCCCFFFXXXXX */ { Lisp_Object slot; + int prog_id; + /* If FFF is nonzero, the CCL program ID is in the + following code. */ + if (rrr) + { + prog_id = XINT (ccl_prog[ic]); + ic++; + } + else + prog_id = field1; + if (stack_idx >= 256 ! || prog_id < 0 ! || prog_id >= XVECTOR (Vccl_program_table)->size ! || (slot = XVECTOR (Vccl_program_table)->contents[prog_id], ! !VECTORP (slot)) ! || !VECTORP (XVECTOR (slot)->contents[1])) { if (stack_idx > 0) { ccl_prog = ccl_prog_stack_struct[0].ccl_prog; ic = ccl_prog_stack_struct[0].ic; } ! CCL_INVALID_CMD; } ! ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog; ccl_prog_stack_struct[stack_idx].ic = ic; stack_idx++; ! ccl_prog = XVECTOR (XVECTOR (slot)->contents[1])->contents; ic = CCL_HEADER_MAIN; } break; *************** *** 998,1005 **** break; case CCL_End: /* 0000000000000000000000XXXXX */ ! if (stack_idx-- > 0) { ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog; ic = ccl_prog_stack_struct[stack_idx].ic; break; --- 1136,1144 ---- break; case CCL_End: /* 0000000000000000000000XXXXX */ ! if (stack_idx > 0) { + stack_idx--; ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog; ic = ccl_prog_stack_struct[stack_idx].ic; break; *************** *** 1009,1017 **** /* ccl->ic should points to this command code again to suppress further processing. */ ic--; ! /* Terminate CCL program successfully. */ ! ccl->status = CCL_STAT_SUCCESS; ! goto ccl_finish; case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */ i = XINT (ccl_prog[ic]); --- 1148,1154 ---- /* ccl->ic should points to this command code again to suppress further processing. */ ic--; ! CCL_SUCCESS; case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */ i = XINT (ccl_prog[ic]); *************** *** 1045,1053 **** case CCL_LE: reg[rrr] = reg[rrr] <= i; break; case CCL_GE: reg[rrr] = reg[rrr] >= i; break; case CCL_NE: reg[rrr] = reg[rrr] != i; break; ! default: ! ccl->status = CCL_STAT_INVALID_CMD; ! goto ccl_error_handler; } break; --- 1182,1188 ---- case CCL_LE: reg[rrr] = reg[rrr] <= i; break; case CCL_GE: reg[rrr] = reg[rrr] >= i; break; case CCL_NE: reg[rrr] = reg[rrr] != i; break; ! default: CCL_INVALID_CMD; } break; *************** *** 1096,1102 **** case CCL_MOD: reg[rrr] = i % j; break; case CCL_AND: reg[rrr] = i & j; break; case CCL_OR: reg[rrr] = i | j; break; ! case CCL_XOR: reg[rrr] = i ^ j; break; case CCL_LSH: reg[rrr] = i << j; break; case CCL_RSH: reg[rrr] = i >> j; break; case CCL_LSH8: reg[rrr] = (i << 8) | j; break; --- 1231,1237 ---- case CCL_MOD: reg[rrr] = i % j; break; case CCL_AND: reg[rrr] = i & j; break; case CCL_OR: reg[rrr] = i | j; break; ! case CCL_XOR: reg[rrr] = i ^ j;; break; case CCL_LSH: reg[rrr] = i << j; break; case CCL_RSH: reg[rrr] = i >> j; break; case CCL_LSH8: reg[rrr] = (i << 8) | j; break; *************** *** 1110,1130 **** case CCL_NE: reg[rrr] = i != j; break; case CCL_DECODE_SJIS: DECODE_SJIS (i, j, reg[rrr], reg[7]); break; case CCL_ENCODE_SJIS: ENCODE_SJIS (i, j, reg[rrr], reg[7]); break; ! default: ! ccl->status = CCL_STAT_INVALID_CMD; ! goto ccl_error_handler; } code &= 0x1F; if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister) { i = reg[rrr]; CCL_WRITE_CHAR (i); } else if (!reg[rrr]) ic = jump_address; break; ! case CCL_Extension: switch (EXCMD) { case CCL_ReadMultibyteChar2: --- 1245,1264 ---- case CCL_NE: reg[rrr] = i != j; break; case CCL_DECODE_SJIS: DECODE_SJIS (i, j, reg[rrr], reg[7]); break; case CCL_ENCODE_SJIS: ENCODE_SJIS (i, j, reg[rrr], reg[7]); break; ! default: CCL_INVALID_CMD; } code &= 0x1F; if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister) { i = reg[rrr]; CCL_WRITE_CHAR (i); + ic = jump_address; } else if (!reg[rrr]) ic = jump_address; break; ! case CCL_Extention: switch (EXCMD) { case CCL_ReadMultibyteChar2: *************** *** 1137,1186 **** src++; goto ccl_read_multibyte_character_suspend; } ! i = *src++; - #if 0 - if (i == LEADING_CODE_COMPOSITION) - { - if (src >= src_end) - goto ccl_read_multibyte_character_suspend; - if (*src == 0xFF) - { - ccl->private_state = COMPOSING_WITH_RULE_HEAD; - src++; - } - else - ccl->private_state = COMPOSING_NO_RULE_HEAD; - - continue; - } - if (ccl->private_state != COMPOSING_NO) - { - /* composite character */ - if (i < 0xA0) - ccl->private_state = COMPOSING_NO; - else - { - if (COMPOSING_WITH_RULE_RULE == ccl->private_state) - { - ccl->private_state = COMPOSING_WITH_RULE_HEAD; - continue; - } - else if (COMPOSING_WITH_RULE_HEAD == ccl->private_state) - ccl->private_state = COMPOSING_WITH_RULE_RULE; - - if (i == 0xA0) - { - if (src >= src_end) - goto ccl_read_multibyte_character_suspend; - i = *src++ & 0x7F; - } - else - i -= 0x20; - } - } - #endif - if (i < 0x80) { /* ASCII */ --- 1271,1278 ---- src++; goto ccl_read_multibyte_character_suspend; } ! i = *src++; if (i < 0x80) { /* ASCII */ *************** *** 1245,1258 **** i = reg[RRR]; /* charset */ if (i == LEADING_BYTE_ASCII) i = reg[rrr] & 0xFF; - #if 0 - else if (i == CHARSET_COMPOSITION) - i = MAKE_COMPOSITE_CHAR (reg[rrr]); - #endif else if (XCHARSET_DIMENSION (CHARSET_BY_LEADING_BYTE (i)) == 1) ! i = ((i - FIELD2_TO_OFFICIAL_LEADING_BYTE) << 7) ! | (reg[rrr] & 0x7F); ! else if (i < MIN_LEADING_BYTE_OFFICIAL_2) i = ((i - FIELD1_TO_OFFICIAL_LEADING_BYTE) << 14) | reg[rrr]; else i = ((i - FIELD1_TO_PRIVATE_LEADING_BYTE) << 14) | reg[rrr]; --- 1337,1346 ---- i = reg[RRR]; /* charset */ if (i == LEADING_BYTE_ASCII) i = reg[rrr] & 0xFF; else if (XCHARSET_DIMENSION (CHARSET_BY_LEADING_BYTE (i)) == 1) ! i = (((i - FIELD2_TO_OFFICIAL_LEADING_BYTE) << 7) ! | (reg[rrr] & 0x7F)); ! else if (i < MAX_LEADING_BYTE_OFFICIAL_2) i = ((i - FIELD1_TO_OFFICIAL_LEADING_BYTE) << 14) | reg[rrr]; else i = ((i - FIELD1_TO_PRIVATE_LEADING_BYTE) << 14) | reg[rrr]; *************** *** 1261,1316 **** break; - #if 0 case CCL_TranslateCharacter: ! i = reg[RRR]; /* charset */ ! if (i == LEADING_BYTE_ASCII) ! i = reg[rrr]; ! else if (i == CHARSET_COMPOSITION) ! { ! reg[RRR] = -1; ! break; ! } ! else if (CHARSET_DIMENSION (i) == 1) ! i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F); ! else if (i < MIN_LEADING_BYTE_OFFICIAL_2) ! i = ((i - 0x8F) << 14) | (reg[rrr] & 0x3FFF); ! else ! i = ((i - 0xE0) << 14) | (reg[rrr] & 0x3FFF); ! op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i, -1, 0, 0); SPLIT_CHAR (op, reg[RRR], i, j); if (j != -1) i = (i << 7) | j; ! reg[rrr] = i; break; case CCL_TranslateCharacterConstTbl: op = XINT (ccl_prog[ic]); /* table */ ic++; ! i = reg[RRR]; /* charset */ ! if (i == LEADING_BYTE_ASCII) ! i = reg[rrr]; ! else if (i == CHARSET_COMPOSITION) ! { ! reg[RRR] = -1; ! break; ! } ! else if (CHARSET_DIMENSION (i) == 1) ! i = ((i - 0x70) << 7) | (reg[rrr] & 0x7F); ! else if (i < MIN_LEADING_BYTE_OFFICIAL_2) ! i = ((i - 0x8F) << 14) | (reg[rrr] & 0x3FFF); ! else ! i = ((i - 0xE0) << 14) | (reg[rrr] & 0x3FFF); ! op = translate_char (GET_TRANSLATION_TABLE (op), i, -1, 0, 0); SPLIT_CHAR (op, reg[RRR], i, j); if (j != -1) i = (i << 7) | j; ! reg[rrr] = i; break; case CCL_IterateMultipleMap: --- 1349,1383 ---- break; case CCL_TranslateCharacter: ! #if 0 ! /* XEmacs does not have translate_char, and its ! equivalent nor. We do nothing on this operation. */ ! CCL_MAKE_CHAR (reg[RRR], reg[rrr], i); op = translate_char (GET_TRANSLATION_TABLE (reg[Rrr]), i, -1, 0, 0); SPLIT_CHAR (op, reg[RRR], i, j); if (j != -1) i = (i << 7) | j; ! reg[rrr] = i; + #endif break; case CCL_TranslateCharacterConstTbl: + #if 0 + /* XEmacs does not have translate_char, and its + equivalent nor. We do nothing on this operation. */ op = XINT (ccl_prog[ic]); /* table */ ic++; ! CCL_MAKE_CHAR (reg[RRR], reg[rrr], i); op = translate_char (GET_TRANSLATION_TABLE (op), i, -1, 0, 0); SPLIT_CHAR (op, reg[RRR], i, j); if (j != -1) i = (i << 7) | j; ! reg[rrr] = i; + #endif break; case CCL_IterateMultipleMap: *************** *** 1344,1350 **** /* Check map varidity. */ if (!CONSP (map)) continue; ! map = XCONS(map)->cdr; if (!VECTORP (map)) continue; size = XVECTOR (map)->size; if (size <= 1) continue; --- 1411,1417 ---- /* Check map varidity. */ if (!CONSP (map)) continue; ! map = XCDR (map); if (!VECTORP (map)) continue; size = XVECTOR (map)->size; if (size <= 1) continue; *************** *** 1354,1360 **** /* check map type, [STARTPOINT VAL1 VAL2 ...] or [t ELELMENT STARTPOINT ENDPOINT] */ ! if (NUMBERP (content)) { point = XUINT (content); point = op - point + 1; --- 1421,1427 ---- /* check map type, [STARTPOINT VAL1 VAL2 ...] or [t ELELMENT STARTPOINT ENDPOINT] */ ! if (INTP (content)) { point = XUINT (content); point = op - point + 1; *************** *** 1370,1381 **** else continue; } ! else continue; if (NILP (content)) continue; ! else if (NUMBERP (content)) { reg[RRR] = i; reg[rrr] = XINT(content); --- 1437,1448 ---- else continue; } ! else continue; if (NILP (content)) continue; ! else if (INTP (content)) { reg[RRR] = i; reg[rrr] = XINT(content); *************** *** 1388,1417 **** } else if (CONSP (content)) { ! attrib = XCONS (content)->car; ! value = XCONS (content)->cdr; ! if (!NUMBERP (attrib) || !NUMBERP (value)) continue; reg[RRR] = i; reg[rrr] = XUINT (value); break; } } if (i == j) reg[RRR] = -1; ic = fin_ic; } break; ! case CCL_MapMultiple: { Lisp_Object map, content, attrib, value; int point, size, map_vector_size; int map_set_rest_length, fin_ic; map_set_rest_length = XINT (ccl_prog[ic++]); /* number of maps and separators. */ fin_ic = ic + map_set_rest_length; if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0)) { ic += reg[RRR]; --- 1455,1505 ---- } else if (CONSP (content)) { ! attrib = XCAR (content); ! value = XCDR (content); ! if (!INTP (attrib) || !INTP (value)) continue; reg[RRR] = i; reg[rrr] = XUINT (value); break; } + else if (SYMBOLP (content)) + CCL_CALL_FOR_MAP_INSTRUCTION (content, fin_ic); + else + CCL_INVALID_CMD; } if (i == j) reg[RRR] = -1; ic = fin_ic; } break; ! case CCL_MapMultiple: { Lisp_Object map, content, attrib, value; int point, size, map_vector_size; int map_set_rest_length, fin_ic; + int current_ic = this_ic; + + /* inhibit recursive call on MapMultiple. */ + if (stack_idx_of_map_multiple > 0) + { + if (stack_idx_of_map_multiple <= stack_idx) + { + stack_idx_of_map_multiple = 0; + mapping_stack_pointer = mapping_stack; + CCL_INVALID_CMD; + } + } + else + mapping_stack_pointer = mapping_stack; + stack_idx_of_map_multiple = 0; map_set_rest_length = XINT (ccl_prog[ic++]); /* number of maps and separators. */ fin_ic = ic + map_set_rest_length; + op = reg[rrr]; + if ((map_set_rest_length > reg[RRR]) && (reg[RRR] >= 0)) { ic += reg[RRR]; *************** *** 1422,1521 **** { ic = fin_ic; reg[RRR] = -1; break; } - mapping_stack_pointer = mapping_stack; - op = reg[rrr]; - PUSH_MAPPING_STACK (0, op); - reg[RRR] = -1; - map_vector_size = XVECTOR (Vcode_conversion_map_vector)->size; - for (;map_set_rest_length > 0;i++, map_set_rest_length--) - { - point = XINT(ccl_prog[ic++]); - if (point < 0) - { - point = -point; - if (mapping_stack_pointer - >= &mapping_stack[MAX_MAP_SET_LEVEL]) - { - CCL_INVALID_CMD; - } - PUSH_MAPPING_STACK (map_set_rest_length - point, - reg[rrr]); - map_set_rest_length = point + 1; - reg[rrr] = op; - continue; - } ! if (point >= map_vector_size) continue; ! map = (XVECTOR (Vcode_conversion_map_vector) ! ->contents[point]); ! ! /* Check map varidity. */ ! if (!CONSP (map)) continue; ! map = XCONS (map)->cdr; ! if (!VECTORP (map)) continue; ! size = XVECTOR (map)->size; ! if (size <= 1) continue; ! ! content = XVECTOR (map)->contents[0]; ! ! /* check map type, ! [STARTPOINT VAL1 VAL2 ...] or ! [t ELEMENT STARTPOINT ENDPOINT] */ ! if (NUMBERP (content)) ! { ! point = XUINT (content); ! point = op - point + 1; ! if (!((point >= 1) && (point < size))) continue; ! content = XVECTOR (map)->contents[point]; ! } ! else if (EQ (content, Qt)) ! { ! if (size != 4) continue; ! if ((op >= XUINT (XVECTOR (map)->contents[2])) && ! (op < XUINT (XVECTOR (map)->contents[3]))) ! content = XVECTOR (map)->contents[1]; ! else ! continue; ! } ! else ! continue; ! if (NILP (content)) ! continue; ! else if (NUMBERP (content)) ! { ! op = XINT (content); ! reg[RRR] = i; ! i += map_set_rest_length; ! POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); ! } ! else if (CONSP (content)) ! { ! attrib = XCONS (content)->car; ! value = XCONS (content)->cdr; ! if (!NUMBERP (attrib) || !NUMBERP (value)) ! continue; ! reg[RRR] = i; ! op = XUINT (value); ! i += map_set_rest_length; ! POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); ! } ! else if (EQ (content, Qt)) { ! reg[RRR] = i; op = reg[rrr]; i += map_set_rest_length; POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); - } - else if (EQ (content, Qlambda)) - { break; } - else - CCL_INVALID_CMD; } ic = fin_ic; } reg[rrr] = op; --- 1510,1674 ---- { ic = fin_ic; reg[RRR] = -1; + mapping_stack_pointer = mapping_stack; break; } ! if (mapping_stack_pointer <= (mapping_stack + 1)) ! { ! /* Set up initial state. */ ! mapping_stack_pointer = mapping_stack; ! PUSH_MAPPING_STACK (0, op); ! reg[RRR] = -1; ! } ! else ! { ! /* Recover after calling other ccl program. */ ! int orig_op; ! POP_MAPPING_STACK (map_set_rest_length, orig_op); ! POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); ! switch (op) { ! case -1: ! /* Regard it as Qnil. */ ! op = orig_op; ! i++; ! ic++; ! map_set_rest_length--; ! break; ! case -2: ! /* Regard it as Qt. */ op = reg[rrr]; + i++; + ic++; + map_set_rest_length--; + break; + case -3: + /* Regard it as Qlambda. */ + op = orig_op; i += map_set_rest_length; + ic += map_set_rest_length; + map_set_rest_length = 0; + break; + default: + /* Regard it as normal mapping. */ + i += map_set_rest_length; + ic += map_set_rest_length; POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); break; } } + map_vector_size = XVECTOR (Vcode_conversion_map_vector)->size; + + do { + for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--) + { + point = XINT(ccl_prog[ic]); + if (point < 0) + { + /* +1 is for including separator. */ + point = -point + 1; + if (mapping_stack_pointer + >= &mapping_stack[MAX_MAP_SET_LEVEL]) + CCL_INVALID_CMD; + PUSH_MAPPING_STACK (map_set_rest_length - point, + reg[rrr]); + map_set_rest_length = point; + reg[rrr] = op; + continue; + } + + if (point >= map_vector_size) continue; + map = (XVECTOR (Vcode_conversion_map_vector) + ->contents[point]); + + /* Check map varidity. */ + if (!CONSP (map)) continue; + map = XCDR (map); + if (!VECTORP (map)) continue; + size = XVECTOR (map)->size; + if (size <= 1) continue; + + content = XVECTOR (map)->contents[0]; + + /* check map type, + [STARTPOINT VAL1 VAL2 ...] or + [t ELEMENT STARTPOINT ENDPOINT] */ + if (INTP (content)) + { + point = XUINT (content); + point = op - point + 1; + if (!((point >= 1) && (point < size))) continue; + content = XVECTOR (map)->contents[point]; + } + else if (EQ (content, Qt)) + { + if (size != 4) continue; + if ((op >= XUINT (XVECTOR (map)->contents[2])) && + (op < XUINT (XVECTOR (map)->contents[3]))) + content = XVECTOR (map)->contents[1]; + else + continue; + } + else + continue; + + if (NILP (content)) + continue; + + reg[RRR] = i; + if (INTP (content)) + { + op = XINT (content); + i += map_set_rest_length - 1; + ic += map_set_rest_length - 1; + POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); + map_set_rest_length++; + } + else if (CONSP (content)) + { + attrib = XCAR (content); + value = XCDR (content); + if (!INTP (attrib) || !INTP (value)) + continue; + op = XUINT (value); + i += map_set_rest_length - 1; + ic += map_set_rest_length - 1; + POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); + map_set_rest_length++; + } + else if (EQ (content, Qt)) + { + op = reg[rrr]; + } + else if (EQ (content, Qlambda)) + { + i += map_set_rest_length; + ic += map_set_rest_length; + break; + } + else if (SYMBOLP (content)) + { + if (mapping_stack_pointer + >= &mapping_stack[MAX_MAP_SET_LEVEL]) + CCL_INVALID_CMD; + PUSH_MAPPING_STACK (map_set_rest_length, reg[rrr]); + PUSH_MAPPING_STACK (map_set_rest_length, op); + stack_idx_of_map_multiple = stack_idx + 1; + CCL_CALL_FOR_MAP_INSTRUCTION (content, current_ic); + } + else + CCL_INVALID_CMD; + } + if (mapping_stack_pointer <= (mapping_stack + 1)) + break; + POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); + i += map_set_rest_length; + ic += map_set_rest_length; + POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); + } while (1); + ic = fin_ic; } reg[rrr] = op; *************** *** 1538,1544 **** reg[RRR] = -1; break; } ! map = XCONS(map)->cdr; if (!VECTORP (map)) { reg[RRR] = -1; --- 1691,1697 ---- reg[RRR] = -1; break; } ! map = XCDR (map); if (!VECTORP (map)) { reg[RRR] = -1; *************** *** 1553,1589 **** reg[RRR] = -1; else { content = XVECTOR (map)->contents[point]; if (NILP (content)) reg[RRR] = -1; ! else if (NUMBERP (content)) reg[rrr] = XINT (content); ! else if (EQ (content, Qt)) ! reg[RRR] = i; else if (CONSP (content)) { ! attrib = XCONS (content)->car; ! value = XCONS (content)->cdr; ! if (!NUMBERP (attrib) || !NUMBERP (value)) continue; reg[rrr] = XUINT(value); break; } else reg[RRR] = -1; } } break; ! #endif ! default: CCL_INVALID_CMD; } break; default: ! ccl->status = CCL_STAT_INVALID_CMD; ! goto ccl_error_handler; } } --- 1706,1742 ---- reg[RRR] = -1; else { + reg[RRR] = 0; content = XVECTOR (map)->contents[point]; if (NILP (content)) reg[RRR] = -1; ! else if (INTP (content)) reg[rrr] = XINT (content); ! else if (EQ (content, Qt)); else if (CONSP (content)) { ! attrib = XCAR (content); ! value = XCDR (content); ! if (!INTP (attrib) || !INTP (value)) continue; reg[rrr] = XUINT(value); break; } + else if (SYMBOLP (content)) + CCL_CALL_FOR_MAP_INSTRUCTION (content, ic); else reg[RRR] = -1; } } break; ! default: CCL_INVALID_CMD; } break; default: ! CCL_INVALID_CMD; } } *************** *** 1595,1609 **** there. */ char msg[256]; - #if 0 /* not for XEmacs ? */ - if (!dst) - dst = destination; - #endif - switch (ccl->status) { - /* Terminate CCL program because of invalid command. - Should not occur in the normal case. */ case CCL_STAT_INVALID_CMD: sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.", code & 0x1F, code, this_ic); --- 1748,1755 ---- *************** *** 1643,1785 **** ccl->stack_idx = stack_idx; ccl->prog = ccl_prog; if (consumed) *consumed = src - source; ! if (destination) ! return Dynarr_length (destination); ! else return 0; } - /* Setup fields of the structure pointed by CCL appropriately for the - execution of compiled CCL code in VEC (vector of integer). - If VEC is nil, we skip setting ups based on VEC. */ - void - setup_ccl_program (struct ccl_program *ccl, Lisp_Object vec) - { - int i; - - if (VECTORP (vec)) - { - ccl->size = XVECTOR_LENGTH (vec); - ccl->prog = XVECTOR_DATA (vec); - ccl->eof_ic = XINT (XVECTOR_DATA (vec)[CCL_HEADER_EOF]); - ccl->buf_magnification = XINT (XVECTOR_DATA (vec)[CCL_HEADER_BUF_MAG]); - } - ccl->ic = CCL_HEADER_MAIN; - for (i = 0; i < 8; i++) - ccl->reg[i] = 0; - ccl->last_block = 0; - ccl->private_state = 0; - ccl->status = 0; - ccl->stack_idx = 0; - } - /* Resolve symbols in the specified CCL code (Lisp vector). This function converts symbols of code conversion maps and character ! translation tables embeded in the CCL code into their ID numbers. */ static Lisp_Object resolve_symbol_ccl_program (Lisp_Object ccl) { ! int i, veclen; ! Lisp_Object result, contents /*, prop */; result = ccl; ! veclen = XVECTOR_LENGTH (result); - /* Set CCL program's table ID */ for (i = 0; i < veclen; i++) { ! contents = XVECTOR_DATA (result)[i]; ! if (SYMBOLP (contents)) { ! if (EQ(result, ccl)) result = Fcopy_sequence (ccl); ! #if 0 ! prop = Fget (contents, Qtranslation_table_id); ! if (NUMBERP (prop)) ! { ! XVECTOR_DATA (result)[i] = prop; ! continue; ! } ! prop = Fget (contents, Qcode_conversion_map_id); ! if (NUMBERP (prop)) ! { ! XVECTOR_DATA (result)[i] = prop; ! continue; ! } ! prop = Fget (contents, Qccl_program_idx); ! if (NUMBERP (prop)) { ! XVECTOR_DATA (result)[i] = prop; ! continue; } ! #endif } } ! return result; } #ifdef emacs DEFUN ("ccl-execute", Fccl_execute, 2, 2, 0, /* Execute CCL-PROGRAM with registers initialized by REGISTERS. ! CCL-PROGRAM is a symbol registered by register-ccl-program, or a compiled code generated by `ccl-compile' (for backward compatibility, ! in this case, the execution is slower). No I/O commands should appear in CCL-PROGRAM. REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value of Nth register. ! As side effect, each element of REGISTER holds the value of corresponding register after the execution. */ ! (ccl_prog, reg)) { struct ccl_program ccl; int i; - Lisp_Object ccl_id; ! if (SYMBOLP (ccl_prog) && ! !NILP (ccl_id = Fget (ccl_prog, Qccl_program_idx, Qnil))) ! { ! ccl_prog = XVECTOR_DATA (Vccl_program_table)[XUINT (ccl_id)]; ! CHECK_LIST (ccl_prog); ! ccl_prog = XCDR (ccl_prog); ! CHECK_VECTOR (ccl_prog); ! } ! else ! { ! CHECK_VECTOR (ccl_prog); ! ccl_prog = resolve_symbol_ccl_program (ccl_prog); ! } CHECK_VECTOR (reg); if (XVECTOR_LENGTH (reg) != 8) ! error ("Invalid length of vector REGISTERS"); - setup_ccl_program (&ccl, ccl_prog); for (i = 0; i < 8; i++) ccl.reg[i] = (INTP (XVECTOR_DATA (reg)[i]) ? XINT (XVECTOR_DATA (reg)[i]) : 0); ! ccl_driver (&ccl, (const unsigned char *)0, (unsigned_char_dynarr *)0, ! 0, (int *)0, CCL_MODE_ENCODING); QUIT; if (ccl.status != CCL_STAT_SUCCESS) error ("Error in CCL program at %dth code", ccl.ic); for (i = 0; i < 8; i++) ! XSETINT (XVECTOR_DATA (reg)[i], ccl.reg[i]); return Qnil; } ! DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, 3, 4, 0, /* Execute CCL-PROGRAM with initial STATUS on STRING. CCL-PROGRAM is a symbol registered by register-ccl-program, --- 1789,2008 ---- ccl->stack_idx = stack_idx; ccl->prog = ccl_prog; if (consumed) *consumed = src - source; ! if (!destination) return 0; + return Dynarr_length (destination); } /* Resolve symbols in the specified CCL code (Lisp vector). This function converts symbols of code conversion maps and character ! translation tables embeded in the CCL code into their ID numbers. + The return value is a vector (CCL itself or a new vector in which + all symbols are resolved), Qt if resolving of some symbol failed, + or nil if CCL contains invalid data. */ + static Lisp_Object resolve_symbol_ccl_program (Lisp_Object ccl) { ! int i, veclen, unresolved = 0; ! Lisp_Object result, contents, val; result = ccl; ! veclen = XVECTOR (result)->size; for (i = 0; i < veclen; i++) { ! contents = XVECTOR (result)->contents[i]; ! if (INTP (contents)) ! continue; ! else if (CONSP (contents) ! && SYMBOLP (XCAR (contents)) ! && SYMBOLP (XCDR (contents))) { ! /* This is the new style for embedding symbols. The form is ! (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give ! an index number. */ ! ! if (EQ (result, ccl)) ! result = Fcopy_sequence (ccl); ! ! val = Fget (XCAR (contents), XCDR (contents), Qnil); ! if (NATNUMP (val)) ! XVECTOR (result)->contents[i] = val; ! else ! unresolved = 1; ! continue; ! } ! else if (SYMBOLP (contents)) ! { ! /* This is the old style for embedding symbols. This style ! may lead to a bug if, for instance, a translation table ! and a code conversion map have the same name. */ ! if (EQ (result, ccl)) result = Fcopy_sequence (ccl); ! val = Fget (contents, Qcode_conversion_map_id, Qnil); ! if (NATNUMP (val)) ! XVECTOR (result)->contents[i] = val; ! else { ! val = Fget (contents, Qccl_program_idx, Qnil); ! if (NATNUMP (val)) ! XVECTOR (result)->contents[i] = val; ! else ! unresolved = 1; } ! continue; } + return Qnil; + } + + return (unresolved ? Qt : result); + } + + /* Return the compiled code (vector) of CCL program CCL_PROG. + CCL_PROG is a name (symbol) of the program or already compiled + code. If necessary, resolve symbols in the compiled code to index + numbers. If we failed to get the compiled code or to resolve + symbols, return Qnil. */ + + static Lisp_Object + ccl_get_compiled_code (Lisp_Object ccl_prog) + { + Lisp_Object val, slot; + + if (VECTORP (ccl_prog)) + { + val = resolve_symbol_ccl_program (ccl_prog); + return (VECTORP (val) ? val : Qnil); } + if (!SYMBOLP (ccl_prog)) + return Qnil; ! val = Fget (ccl_prog, Qccl_program_idx, Qnil); ! if (! NATNUMP (val) ! || XINT (val) >= XVECTOR_LENGTH (Vccl_program_table)) ! return Qnil; ! slot = XVECTOR_DATA (Vccl_program_table)[XINT (val)]; ! if (! VECTORP (slot) ! || XVECTOR (slot)->size != 3 ! || ! VECTORP (XVECTOR_DATA (slot)[1])) ! return Qnil; ! if (NILP (XVECTOR_DATA (slot)[2])) ! { ! val = resolve_symbol_ccl_program (XVECTOR_DATA (slot)[1]); ! if (! VECTORP (val)) ! return Qnil; ! XVECTOR_DATA (slot)[1] = val; ! XVECTOR_DATA (slot)[2] = Qt; ! } ! return XVECTOR_DATA (slot)[1]; } + /* Setup fields of the structure pointed by CCL appropriately for the + execution of CCL program CCL_PROG. CCL_PROG is the name (symbol) + of the CCL program or the already compiled code (vector). + Return 0 if we succeed this setup, else return -1. + + If CCL_PROG is nil, we just reset the structure pointed by CCL. */ + int + setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog) + { + int i; + + if (! NILP (ccl_prog)) + { + ccl_prog = ccl_get_compiled_code (ccl_prog); + if (! VECTORP (ccl_prog)) + return -1; + ccl->size = XVECTOR_LENGTH (ccl_prog); + ccl->prog = XVECTOR_DATA (ccl_prog); + ccl->eof_ic = XINT (XVECTOR_DATA (ccl_prog)[CCL_HEADER_EOF]); + ccl->buf_magnification = XINT (XVECTOR_DATA (ccl_prog)[CCL_HEADER_BUF_MAG]); + } + ccl->ic = CCL_HEADER_MAIN; + for (i = 0; i < 8; i++) + ccl->reg[i] = 0; + ccl->last_block = 0; + ccl->private_state = 0; + ccl->status = 0; + ccl->stack_idx = 0; + ccl->eol_type = CCL_CODING_EOL_LF; + return 0; + } #ifdef emacs + DEFUN ("ccl-program-p", Fccl_program_p, 1, 1, 0, /* + Return t if OBJECT is a CCL program name or a compiled CCL program code. + See the documentation of `define-ccl-program' for the detail of CCL program. + */ + (object)) + { + Lisp_Object val; + + if (VECTORP (object)) + { + val = resolve_symbol_ccl_program (object); + return (VECTORP (val) ? Qt : Qnil); + } + if (!SYMBOLP (object)) + return Qnil; + + val = Fget (object, Qccl_program_idx, Qnil); + return ((! NATNUMP (val) + || XINT (val) >= XVECTOR_LENGTH (Vccl_program_table)) + ? Qnil : Qt); + } + DEFUN ("ccl-execute", Fccl_execute, 2, 2, 0, /* Execute CCL-PROGRAM with registers initialized by REGISTERS. ! CCL-PROGRAM is a CCL program name (symbol) or a compiled code generated by `ccl-compile' (for backward compatibility, ! in this case, the overhead of the execution is bigger than the former case). No I/O commands should appear in CCL-PROGRAM. REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value of Nth register. ! As side effect, each element of REGISTERS holds the value of corresponding register after the execution. + + See the documentation of `define-ccl-program' for the detail of CCL program. */ ! (ccl_prog, reg)) { struct ccl_program ccl; int i; ! if (setup_ccl_program (&ccl, ccl_prog) < 0) ! error ("Invalid CCL program"); CHECK_VECTOR (reg); if (XVECTOR_LENGTH (reg) != 8) ! error ("Length of vector REGISTERS is not 8"); for (i = 0; i < 8; i++) ccl.reg[i] = (INTP (XVECTOR_DATA (reg)[i]) ? XINT (XVECTOR_DATA (reg)[i]) : 0); ! ccl_driver (&ccl, (const unsigned char *)0, ! (unsigned_char_dynarr *)0, 0, (int *)0, ! CCL_MODE_ENCODING); QUIT; if (ccl.status != CCL_STAT_SUCCESS) error ("Error in CCL program at %dth code", ccl.ic); for (i = 0; i < 8; i++) ! XSETINT (XVECTOR (reg)->contents[i], ccl.reg[i]); return Qnil; } ! DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, ! 3, 4, 0, /* Execute CCL-PROGRAM with initial STATUS on STRING. CCL-PROGRAM is a symbol registered by register-ccl-program, *************** *** 1788,1794 **** Read buffer is set to STRING, and write buffer is allocated automatically. - If IC is nil, it is initialized to head of the CCL program.\n\ STATUS is a vector of [R0 R1 ... R7 IC], where R0..R7 are initial values of corresponding registers, IC is the instruction counter specifying from where to start the program. --- 2011,2016 ---- *************** *** 1801,1837 **** It returns the contents of write buffer as a string, and as side effect, STATUS is updated. */ ! (ccl_prog, status, str, contin)) { Lisp_Object val; struct ccl_program ccl; int i, produced; unsigned_char_dynarr *outbuf; ! struct gcpro gcpro1, gcpro2, gcpro3; ! Lisp_Object ccl_id; ! if (SYMBOLP (ccl_prog) && ! !NILP (ccl_id = Fget (ccl_prog, Qccl_program_idx, Qnil))) ! { ! ccl_prog = XVECTOR (Vccl_program_table)->contents[XUINT (ccl_id)]; ! CHECK_LIST (ccl_prog); ! ccl_prog = XCDR (ccl_prog); ! CHECK_VECTOR (ccl_prog); ! } ! else ! { ! CHECK_VECTOR (ccl_prog); ! ccl_prog = resolve_symbol_ccl_program (ccl_prog); ! } CHECK_VECTOR (status); ! if (XVECTOR_LENGTH (status) != 9) ! signal_simple_error ("Vector should be of length 9", status); CHECK_STRING (str); - GCPRO3 (ccl_prog, status, str); ! setup_ccl_program (&ccl, ccl_prog); for (i = 0; i < 8; i++) { if (NILP (XVECTOR_DATA (status)[i])) --- 2023,2049 ---- It returns the contents of write buffer as a string, and as side effect, STATUS is updated. + + See the documentation of `define-ccl-program' for the detail of CCL program. */ ! (ccl_prog, status, str, contin)) { Lisp_Object val; struct ccl_program ccl; int i, produced; unsigned_char_dynarr *outbuf; ! struct gcpro gcpro1, gcpro2; ! if (setup_ccl_program (&ccl, ccl_prog) < 0) ! error ("Invalid CCL program"); CHECK_VECTOR (status); ! if (XVECTOR (status)->size != 9) ! error ("Length of vector STATUS is not 9"); CHECK_STRING (str); ! GCPRO2 (status, str); ! for (i = 0; i < 8; i++) { if (NILP (XVECTOR_DATA (status)[i])) *************** *** 1839,1845 **** if (INTP (XVECTOR_DATA (status)[i])) ccl.reg[i] = XINT (XVECTOR_DATA (status)[i]); } ! if (INTP (XVECTOR_DATA (status)[8])) { i = XINT (XVECTOR_DATA (status)[8]); if (ccl.ic < i && i < ccl.size) --- 2051,2057 ---- if (INTP (XVECTOR_DATA (status)[i])) ccl.reg[i] = XINT (XVECTOR_DATA (status)[i]); } ! if (INTP (XVECTOR (status)->contents[i])) { i = XINT (XVECTOR_DATA (status)[8]); if (ccl.ic < i && i < ccl.size) *************** *** 1847,1956 **** } outbuf = Dynarr_new (unsigned_char); ccl.last_block = NILP (contin); ! produced = ccl_driver (&ccl, XSTRING_DATA (str), outbuf, ! XSTRING_LENGTH (str), (int *)0, CCL_MODE_DECODING); for (i = 0; i < 8; i++) ! XVECTOR_DATA (status)[i] = make_int(ccl.reg[i]); XSETINT (XVECTOR_DATA (status)[8], ccl.ic); UNGCPRO; val = make_string (Dynarr_atp (outbuf, 0), produced); Dynarr_free (outbuf); QUIT; if (ccl.status != CCL_STAT_SUCCESS ! && ccl.status != CCL_STAT_SUSPEND_BY_SRC ! && ccl.status != CCL_STAT_SUSPEND_BY_DST) error ("Error in CCL program at %dth code", ccl.ic); return val; } ! DEFUN ("register-ccl-program", Fregister_ccl_program, 2, 2, 0, /* ! Register CCL program PROGRAM of NAME in `ccl-program-table'. ! PROGRAM should be a compiled code of CCL program, or nil. ! Return index number of the registered CCL program. */ ! (name, ccl_prog)) { int len = XVECTOR_LENGTH (Vccl_program_table); ! int i; CHECK_SYMBOL (name); if (!NILP (ccl_prog)) { CHECK_VECTOR (ccl_prog); ! ccl_prog = resolve_symbol_ccl_program (ccl_prog); } ! for (i = 0; i < len; i++) { ! Lisp_Object slot = XVECTOR_DATA (Vccl_program_table)[i]; ! if (!CONSP (slot)) break; ! if (EQ (name, XCAR (slot))) { ! XCDR (slot) = ccl_prog; ! return make_int (i); } } ! if (i == len) { ! Lisp_Object new_table = Fmake_vector (make_int (len * 2), Qnil); int j; for (j = 0; j < len; j++) XVECTOR_DATA (new_table)[j] = XVECTOR_DATA (Vccl_program_table)[j]; Vccl_program_table = new_table; } ! XVECTOR_DATA (Vccl_program_table)[i] = Fcons (name, ccl_prog); ! Fput (name, Qccl_program_idx, make_int (i)); ! return make_int (i); } - #if 0 /* Register code conversion map. A code conversion map consists of numbers, Qt, Qnil, and Qlambda. The first element is start code point. The rest elements are mapped numbers. Symbol t means to map to an original number before mapping. Symbol nil means that the corresponding element is empty. ! Symbol lambda means to terminate mapping here. */ DEFUN ("register-code-conversion-map", Fregister_code_conversion_map, ! Sregister_code_conversion_map, ! 2, 2, 0, ! "Register SYMBOL as code conversion map MAP.\n\ ! Return index number of the registered map.") ! (symbol, map) ! Lisp_Object symbol, map; { ! int len = XVECTOR (Vcode_conversion_map_vector)->size; int i; ! Lisp_Object index; ! ! CHECK_SYMBOL (symbol, 0); ! CHECK_VECTOR (map, 1); for (i = 0; i < len; i++) { ! Lisp_Object slot = XVECTOR (Vcode_conversion_map_vector)->contents[i]; if (!CONSP (slot)) break; ! if (EQ (symbol, XCONS (slot)->car)) { ! index = make_int (i); ! XCONS (slot)->cdr = map; Fput (symbol, Qcode_conversion_map, map); ! Fput (symbol, Qcode_conversion_map_id, index); ! return index; } } --- 2059,2193 ---- } outbuf = Dynarr_new (unsigned_char); ccl.last_block = NILP (contin); ! produced = ccl_driver (&ccl, XSTRING (str)->data, outbuf, ! XSTRING_LENGTH (str), ! (int *) 0, ! CCL_MODE_DECODING); for (i = 0; i < 8; i++) ! XSETINT (XVECTOR_DATA (status)[i], ccl.reg[i]); XSETINT (XVECTOR_DATA (status)[8], ccl.ic); UNGCPRO; val = make_string (Dynarr_atp (outbuf, 0), produced); Dynarr_free (outbuf); QUIT; + if (ccl.status == CCL_STAT_SUSPEND_BY_DST) + error ("Output buffer for the CCL programs overflow"); if (ccl.status != CCL_STAT_SUCCESS ! && ccl.status != CCL_STAT_SUSPEND_BY_SRC) error ("Error in CCL program at %dth code", ccl.ic); return val; } ! DEFUN ("register-ccl-program", Fregister_ccl_program, ! 2, 2, 0, /* ! Register CCL program CCL_PROG as NAME in `ccl-program-table'. ! CCL_PROG should be a compiled CCL program (vector), or nil. ! If it is nil, just reserve NAME as a CCL program name. ! Return index number of the registered CCL program." */ ! (name, ccl_prog)) { int len = XVECTOR_LENGTH (Vccl_program_table); ! int idx; ! Lisp_Object resolved; CHECK_SYMBOL (name); + resolved = Qnil; if (!NILP (ccl_prog)) { CHECK_VECTOR (ccl_prog); ! resolved = resolve_symbol_ccl_program (ccl_prog); ! if (! NILP (resolved)) ! { ! ccl_prog = resolved; ! resolved = Qt; ! } } ! for (idx = 0; idx < len; idx++) { ! Lisp_Object slot; ! slot = XVECTOR_DATA (Vccl_program_table)[idx]; ! if (!VECTORP (slot)) ! /* This is the first unsed slot. Register NAME here. */ break; ! if (EQ (name, XVECTOR_DATA (slot)[0])) { ! /* Update this slot. */ ! XVECTOR_DATA (slot)[1] = ccl_prog; ! XVECTOR_DATA (slot)[2] = resolved; ! return make_int (idx); } } ! if (idx == len) { ! /* Extend the table. */ ! Lisp_Object new_table; int j; + new_table = Fmake_vector (make_int (len * 2), Qnil); for (j = 0; j < len; j++) XVECTOR_DATA (new_table)[j] = XVECTOR_DATA (Vccl_program_table)[j]; Vccl_program_table = new_table; } + + { + Lisp_Object elt; ! elt = Fmake_vector (make_int (3), Qnil); ! XVECTOR_DATA (elt)[0] = name; ! XVECTOR_DATA (elt)[1] = ccl_prog; ! XVECTOR_DATA (elt)[2] = resolved; ! XVECTOR_DATA (Vccl_program_table)[idx] = elt; ! } ! ! Fput (name, Qccl_program_idx, make_int (idx)); ! return make_int (idx); } /* Register code conversion map. A code conversion map consists of numbers, Qt, Qnil, and Qlambda. The first element is start code point. The rest elements are mapped numbers. Symbol t means to map to an original number before mapping. Symbol nil means that the corresponding element is empty. ! Symbol lambda menas to terminate mapping here. */ DEFUN ("register-code-conversion-map", Fregister_code_conversion_map, ! 2, 2, 0, /* ! Register SYMBOL as code conversion map MAP. ! Return index number of the registered map. ! */ ! (symbol, map)) { ! int len = XVECTOR_LENGTH (Vcode_conversion_map_vector); int i; ! Lisp_Object idx; + CHECK_SYMBOL (symbol); + CHECK_VECTOR (map); + for (i = 0; i < len; i++) { ! Lisp_Object slot = XVECTOR_DATA (Vcode_conversion_map_vector)[i]; if (!CONSP (slot)) break; ! if (EQ (symbol, XCAR (slot))) { ! idx = make_int (i); ! XCDR (slot) = map; Fput (symbol, Qcode_conversion_map, map); ! Fput (symbol, Qcode_conversion_map_id, idx); ! return idx; } } *************** *** 1960,1988 **** int j; for (j = 0; j < len; j++) ! XVECTOR (new_vector)->contents[j] ! = XVECTOR (Vcode_conversion_map_vector)->contents[j]; Vcode_conversion_map_vector = new_vector; } ! index = make_int (i); Fput (symbol, Qcode_conversion_map, map); ! Fput (symbol, Qcode_conversion_map_id, index); ! XVECTOR (Vcode_conversion_map_vector)->contents[i] = Fcons (symbol, map); ! return index; } - #endif void syms_of_mule_ccl (void) { DEFSUBR (Fccl_execute); DEFSUBR (Fccl_execute_on_string); DEFSUBR (Fregister_ccl_program); ! #if 0 ! DEFSUBR (&Fregister_code_conversion_map); ! #endif } void --- 2197,2223 ---- int j; for (j = 0; j < len; j++) ! XVECTOR_DATA (new_vector)[j] ! = XVECTOR_DATA (Vcode_conversion_map_vector)[j]; Vcode_conversion_map_vector = new_vector; } ! idx = make_int (i); Fput (symbol, Qcode_conversion_map, map); ! Fput (symbol, Qcode_conversion_map_id, idx); ! XVECTOR_DATA (Vcode_conversion_map_vector)[i] = Fcons (symbol, map); ! return idx; } void syms_of_mule_ccl (void) { + DEFSUBR (Fccl_program_p); DEFSUBR (Fccl_execute); DEFSUBR (Fccl_execute_on_string); DEFSUBR (Fregister_ccl_program); ! DEFSUBR (Fregister_code_conversion_map); } void *************** *** 1990,2013 **** { staticpro (&Vccl_program_table); Vccl_program_table = Fmake_vector (make_int (32), Qnil); - - Qccl_program = intern ("ccl-program"); - staticpro (&Qccl_program); ! Qccl_program_idx = intern ("ccl-program-idx"); ! staticpro (&Qccl_program_idx); - #if 0 - Qcode_conversion_map = intern ("code-conversion-map"); - staticpro (&Qcode_conversion_map); - - Qcode_conversion_map_id = intern ("code-conversion-map-id"); - staticpro (&Qcode_conversion_map_id); - DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector /* ! Vector of code conversion maps.*/ ); Vcode_conversion_map_vector = Fmake_vector (make_int (16), Qnil); - #endif DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist /* Alist of fontname patterns vs corresponding CCL program. --- 2225,2240 ---- { staticpro (&Vccl_program_table); Vccl_program_table = Fmake_vector (make_int (32), Qnil); ! defsymbol (&Qccl_program, "ccl-program"); ! defsymbol (&Qccl_program_idx, "ccl-program-idx"); ! defsymbol (&Qcode_conversion_map, "code-conversion-map"); ! defsymbol (&Qcode_conversion_map_id, "code-conversion-map-id"); DEFVAR_LISP ("code-conversion-map-vector", &Vcode_conversion_map_vector /* ! Vector of code conversion maps. ! */ ); Vcode_conversion_map_vector = Fmake_vector (make_int (16), Qnil); DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist /* Alist of fontname patterns vs corresponding CCL program. Index: src/mule-ccl.h =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/mule-ccl.h,v retrieving revision 1.1.2.5 diff -c -r1.1.2.5 mule-ccl.h *** mule-ccl.h 2000/02/16 02:06:46 1.1.2.5 --- mule-ccl.h 2000/10/05 15:19:56 *************** *** 1,5 **** /* Header for CCL (Code Conversion Language) interpreter. ! Copyright (C) 1995,1999 Electrotechnical Laboratory, JAPAN. Licensed to the Free Software Foundation. This file is part of XEmacs. --- 1,5 ---- /* Header for CCL (Code Conversion Language) interpreter. ! Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. Licensed to the Free Software Foundation. This file is part of XEmacs. *************** *** 19,26 **** the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - /* Synched up with: FSF Emacs 20.3.10 */ - #ifndef INCLUDED_mule_ccl_h_ #define INCLUDED_mule_ccl_h_ --- 19,24 ---- *************** *** 44,51 **** condition flag of relational operations. */ int private_state; /* CCL instruction may use this ! for private use, mainly for preservation ! internal states for suspending. This variable is set to 0 when ccl is set up. */ int last_block; /* Set to 1 while processing the last --- 42,49 ---- condition flag of relational operations. */ int private_state; /* CCL instruction may use this ! for private use, mainly for saving ! internal states on suspending. This variable is set to 0 when ccl is set up. */ int last_block; /* Set to 1 while processing the last *************** *** 55,73 **** many times bigger the output buffer should be than the input buffer. */ int stack_idx; /* How deep the call of CCL_Call is nested. */ }; - #define CCL_MODE_ENCODING 0 #define CCL_MODE_DECODING 1 ! int ccl_driver (struct ccl_program *ccl, const unsigned char *source, ! unsigned_char_dynarr *destination, int src_bytes, ! int *consumed, int conversion_mode); ! void setup_ccl_program (struct ccl_program *ccl, Lisp_Object val); /* Alist of fontname patterns vs corresponding CCL program. */ extern Lisp_Object Vfont_ccl_encoder_alist; extern Lisp_Object Qccl_program; #endif /* INCLUDED_mule_ccl_h_ */ --- 53,93 ---- many times bigger the output buffer should be than the input buffer. */ int stack_idx; /* How deep the call of CCL_Call is nested. */ + int eol_type; /* When the CCL program is used for + encoding by a coding system, set to + the eol_type of the coding + system. */ + int multibyte; /* 1 if the source text is multibyte. */ }; #define CCL_MODE_ENCODING 0 #define CCL_MODE_DECODING 1 ! #define CCL_CODING_EOL_LF 0 /* Line-feed only, same as Emacs' ! internal format. */ ! #define CCL_CODING_EOL_CRLF 1 /* Sequence of carriage-return and ! line-feed. */ ! #define CCL_CODING_EOL_CR 2 /* Carriage-return only. */ /* Alist of fontname patterns vs corresponding CCL program. */ extern Lisp_Object Vfont_ccl_encoder_alist; + + /* Setup fields of the structure pointed by CCL appropriately for the + execution of ccl program CCL_PROG (symbol or vector). */ + extern int setup_ccl_program (struct ccl_program *, Lisp_Object); + + extern int ccl_driver (struct ccl_program *, const unsigned char *, + unsigned_char_dynarr *, int, int *, int); + + EXFUN (Fregister_ccl_program, 2); + extern Lisp_Object Qccl_program; + + /* Vector of CCL program names vs corresponding program data. */ + extern Lisp_Object Vccl_program_table; + + /* Symbols of ccl program have this property, a value of the property + is an index for Vccl_protram_table. */ + extern Lisp_Object Qccl_program_idx; #endif /* INCLUDED_mule_ccl_h_ */ Index: src/redisplay-msw.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/redisplay-msw.c,v retrieving revision 1.28.2.29 diff -c -r1.28.2.29 redisplay-msw.c *** redisplay-msw.c 2000/08/06 10:01:17 1.28.2.29 --- redisplay-msw.c 2000/10/05 15:20:08 *************** *** 134,142 **** #ifdef MULE { Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); ! need_ccl_conversion = !NILP (ccl_prog); ! if (need_ccl_conversion) ! setup_ccl_program (&char_converter, ccl_prog); } #endif } --- 134,142 ---- #ifdef MULE { Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); ! if ((!NILP (ccl_prog)) ! && (setup_ccl_program (&char_converter, ccl_prog) >= 0)) ! need_ccl_conversion = 1; } #endif } Index: src/redisplay-x.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/redisplay-x.c,v retrieving revision 1.23.2.28 diff -c -r1.23.2.28 redisplay-x.c *** redisplay-x.c 2000/10/03 06:29:31 1.23.2.28 --- redisplay-x.c 2000/10/05 15:20:18 *************** *** 165,173 **** #ifdef MULE { Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); ! need_ccl_conversion = !NILP (ccl_prog); ! if (need_ccl_conversion) ! setup_ccl_program (&char_converter, ccl_prog); } #endif } --- 165,173 ---- #ifdef MULE { Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); ! if ((!NILP (ccl_prog)) ! && (setup_ccl_program (&char_converter, ccl_prog) >= 0)) ! need_ccl_conversion = 1; } #endif } from himi