annotate lisp/mule/mule-ccl.el @ 788:026c5bf9c134

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