|
70
|
1 ;;; mule-ccl.el --- Code Conversion Language functions.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; This file is part of XEmacs.
|
|
|
6
|
|
|
7 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
8 ;; under the terms of the GNU General Public License as published by
|
|
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
10 ;; any later version.
|
|
|
11
|
|
|
12 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
15 ;; General Public License for more details.
|
|
|
16
|
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
|
18 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
20 ;; Boston, MA 02111-1307, USA.
|
|
|
21
|
|
|
22 ;;; 93.5.26 created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
|
|
|
23
|
|
|
24 ;;;; #### This stuff doesn't work yet.
|
|
|
25
|
|
|
26 (defconst ccl-operator-table
|
|
|
27 '[if branch loop break repeat write-repeat write-read-repeat
|
|
|
28 read read-if read-branch write end])
|
|
|
29
|
|
|
30 (let (op (i 0) (len (length ccl-operator-table)))
|
|
|
31 (while (< i len)
|
|
|
32 (setq op (aref ccl-operator-table i))
|
|
|
33 (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
|
|
|
34 (setq i (1+ i))))
|
|
|
35
|
|
|
36 (defconst ccl-machine-code-table
|
|
|
37 '[set-cs set-cl set-r set-a
|
|
|
38 jump jump-cond write-jump write-read-jump write-c-jump
|
|
|
39 write-c-read-jump write-s-jump write-s-read-jump write-a-read-jump
|
|
|
40 branch
|
|
|
41 read1 read2 read-branch write1 write2 write-c write-s write-a
|
|
|
42 end
|
|
|
43 set-self-cs set-self-cl set-self-r set-expr-cl set-expr-r
|
|
|
44 jump-cond-c jump-cond-r read-jump-cond-c read-jump-cond-r
|
|
|
45 ])
|
|
|
46
|
|
|
47 (let (code (i 0) (len (length ccl-machine-code-table)))
|
|
|
48 (while (< i len)
|
|
|
49 (setq code (aref ccl-machine-code-table i))
|
|
|
50 (put code 'ccl-code i)
|
|
|
51 (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
|
|
|
52 (setq i (1+ i))))
|
|
|
53
|
|
|
54 (defconst ccl-register-table '[r0 r1 r2 r3 r4 r5 r6 r7])
|
|
|
55
|
|
|
56 (let (reg (i 0) (len (length ccl-register-table)))
|
|
|
57 (while (< i len)
|
|
|
58 (setq reg (aref ccl-register-table i))
|
|
|
59 (put reg 'ccl-register-number i)
|
|
|
60 (setq i (1+ i))))
|
|
|
61
|
|
|
62 (defconst ccl-arith-table
|
|
|
63 '[+ - * / % & | ^ << >> <8 >8 // nil nil nil < > == <= >= !=])
|
|
|
64
|
|
|
65 (let (arith (i 0) (len (length ccl-arith-table)))
|
|
|
66 (while (< i len)
|
|
|
67 (setq arith (aref ccl-arith-table i))
|
|
|
68 (if arith (put arith 'ccl-arith-code i))
|
|
|
69 (setq i (1+ i))))
|
|
|
70
|
|
|
71 (defconst ccl-self-arith-table
|
|
|
72 '[+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=])
|
|
|
73
|
|
|
74 (let (arith (i 0) (len (length ccl-self-arith-table)))
|
|
|
75 (while (< i len)
|
|
|
76 (setq arith (aref ccl-self-arith-table i))
|
|
|
77 (put arith 'ccl-self-arith-code i)
|
|
|
78 (setq i (1+ i))))
|
|
|
79
|
|
|
80 ;; this holds the compiled CCL program as it is being compiled.
|
|
|
81 (defvar ccl-program-vector nil)
|
|
|
82
|
|
|
83 ;; this holds the index into ccl-program-vector where the next
|
|
|
84 ;; instruction is to be stored.
|
|
|
85 (defvar ccl-current-ic 0)
|
|
|
86
|
|
|
87 ;; add a constant to the compiled CCL program, either at IC (if specified)
|
|
|
88 ;; or at the current instruction counter (and bumping that value)
|
|
|
89 (defun ccl-embed-const (const &optional ic)
|
|
|
90 (if ic
|
|
|
91 (aset ccl-program-vector ic const)
|
|
|
92 (aset ccl-program-vector ccl-current-ic const)
|
|
|
93 (setq ccl-current-ic (1+ ccl-current-ic))))
|
|
|
94
|
|
|
95 (defun ccl-embed-code (op reg const &optional ic)
|
|
|
96 (let ((machine-code (logior (get op 'ccl-code)
|
|
|
97 (if (symbolp reg)
|
|
|
98 (ash (get reg 'ccl-register-number) 5)
|
|
|
99 0)
|
|
|
100 (ash const 8))))
|
|
|
101 (if ic
|
|
|
102 (aset ccl-program-vector ic machine-code)
|
|
|
103 (aset ccl-program-vector ccl-current-ic machine-code)
|
|
|
104 (setq ccl-current-ic (1+ ccl-current-ic)))))
|
|
|
105
|
|
|
106 ;; advance the instruction counter by INC without doing anything else
|
|
|
107 (defun ccl-embed-nop (&optional inc)
|
|
|
108 (setq ccl-current-ic (+ ccl-current-ic (or inc 1))))
|
|
|
109
|
|
|
110 ;;;###autoload
|
|
|
111 (defun ccl-program-p (obj)
|
|
|
112 "T if OBJECT is a valid CCL compiled code."
|
|
|
113 (and (vectorp obj)
|
|
|
114 (let ((i 0) (len (length obj)) (flag t))
|
|
|
115 (if (> len 1)
|
|
|
116 (progn
|
|
|
117 (while (and flag (< i len))
|
|
|
118 (setq flag (integerp (aref obj i)))
|
|
|
119 (setq i (1+ i)))
|
|
|
120 flag)))))
|
|
|
121
|
|
|
122 (defvar ccl-loop-head nil)
|
|
|
123 (defvar ccl-breaks nil)
|
|
|
124
|
|
|
125 ;;;###autoload
|
|
|
126 (defun ccl-compile (ccl-program)
|
|
|
127 "Compile a CCL source program and return the compiled equivalent.
|
|
|
128 The return value will be a vector of integers."
|
|
|
129 (if (or (null (consp ccl-program))
|
|
|
130 (null (listp (car ccl-program))))
|
|
|
131 (error "CCL: Invalid source program: %s" ccl-program))
|
|
|
132 (if (null (vectorp ccl-program-vector))
|
|
|
133 (setq ccl-program-vector (make-vector 8192 0))
|
|
|
134 ;; perhaps not necessary but guarantees some sort of determinism
|
|
|
135 (fillarray ccl-program-vector 0))
|
|
|
136 (setq ccl-loop-head nil ccl-breaks nil)
|
|
|
137 (setq ccl-current-ic 0)
|
|
|
138 ;; leave space for offset to EOL program
|
|
|
139 (ccl-embed-nop)
|
|
|
140 (ccl-compile-1 (car ccl-program))
|
|
|
141 ;; store offset to EOL program in first word of compiled prog
|
|
|
142 (ccl-embed-const ccl-current-ic 0)
|
|
|
143 (if (car (cdr ccl-program))
|
|
|
144 (ccl-compile-1 (car (cdr ccl-program))))
|
|
|
145 (ccl-embed-code 'end 0 0)
|
|
|
146 (let ((vec (make-vector ccl-current-ic 0))
|
|
|
147 (i 0))
|
|
|
148 (while (< i ccl-current-ic)
|
|
|
149 (aset vec i (aref ccl-program-vector i))
|
|
|
150 (setq i (1+ i)))
|
|
|
151 vec))
|
|
|
152
|
|
|
153 (defun ccl-check-constant (arg cmd)
|
|
|
154 (if (>= arg 0)
|
|
|
155 arg
|
|
|
156 (error "CCL: Negative constant %s not allowed: %s" arg cmd)))
|
|
|
157
|
|
|
158 (defun ccl-check-register (arg cmd)
|
|
|
159 (if (get arg 'ccl-register-number)
|
|
|
160 arg
|
|
|
161 (error "CCL: Invalid register %s: %s" arg cmd)))
|
|
|
162
|
|
|
163 (defun ccl-check-reg-const (arg cmd)
|
|
|
164 (if (integer-or-char-p arg)
|
|
|
165 (ccl-check-constant arg cmd)
|
|
|
166 (ccl-check-register arg cmd)))
|
|
|
167
|
|
|
168 (defun ccl-check-compile-function (arg cmd)
|
|
|
169 (or (get arg 'ccl-compile-function)
|
|
|
170 (error "CCL: Invalid command: %s" cmd)))
|
|
|
171
|
|
|
172 ;; compile a block of CCL code (see CCL_BLOCK above).
|
|
|
173 (defun ccl-compile-1 (cmd-list)
|
|
|
174 (let (cmd)
|
|
|
175 ;; a CCL_BLOCK is either STATEMENT or (STATEMENT [STATEMENT ...])
|
|
|
176 ;; convert the former into the latter.
|
|
|
177 (if (or (not (listp cmd-list))
|
|
|
178 (and cmd-list (symbolp (car cmd-list))))
|
|
|
179 (setq cmd-list (list cmd-list)))
|
|
|
180 (while cmd-list
|
|
|
181 (setq cmd (car cmd-list))
|
|
|
182 ;; an int-or-char is equivalent to (r0 = int-or-char)
|
|
|
183 ;; a string is equivalent to (write string)
|
|
|
184 ;; convert the above two into their equivalent forms.
|
|
|
185 ;; everything else is a list.
|
|
|
186 (cond ((integer-or-char-p cmd)
|
|
|
187 (ccl-compile-set (list 'r0 '= cmd)))
|
|
|
188 ((stringp cmd)
|
|
|
189 (ccl-compile-write-string (list 'write cmd)))
|
|
|
190 ((listp cmd)
|
|
|
191 (if (eq (nth 1 cmd) '=)
|
|
|
192 (ccl-compile-set cmd)
|
|
|
193 (if (and (symbolp (nth 1 cmd))
|
|
|
194 (get (nth 1 cmd) 'ccl-self-arith-code))
|
|
|
195 (ccl-compile-self-set cmd)
|
|
|
196 (funcall (ccl-check-compile-function (car cmd) cmd) cmd))))
|
|
|
197 (t
|
|
|
198 (error "CCL: Invalid command: %s" cmd)))
|
|
|
199 (setq cmd-list (cdr cmd-list)))))
|
|
|
200
|
|
|
201 (defun ccl-compile-set (cmd)
|
|
|
202 (let ((rrr (ccl-check-register (car cmd) cmd))
|
|
|
203 (right (nth 2 cmd)))
|
|
|
204 (cond ((listp right)
|
|
|
205 ;; cmd == (RRR = (XXX OP YYY))
|
|
|
206 (ccl-compile-expression rrr right))
|
|
|
207 ((integer-or-char-p right)
|
|
|
208 (ccl-check-constant right cmd)
|
|
|
209 (if (< right 524288) ; (< right 2^19)
|
|
|
210 (ccl-embed-code 'set-cs rrr right)
|
|
|
211 (ccl-embed-code 'set-cl rrr 0)
|
|
|
212 (ccl-embed-const right)))
|
|
|
213 (t
|
|
|
214 (ccl-check-register right cmd)
|
|
|
215 (let ((ary (nth 3 cmd)))
|
|
|
216 (if (vectorp ary)
|
|
|
217 (let ((i 0) (len (length ary)))
|
|
|
218 (ccl-embed-code 'set-a rrr (get right 'ccl-register-number))
|
|
|
219 (ccl-embed-const len)
|
|
|
220 (while (< i len)
|
|
|
221 (ccl-check-constant (aref ary i) cmd)
|
|
|
222 (ccl-embed-const (aref ary i))
|
|
|
223 (setq i (1+ i))))
|
|
|
224 (ccl-embed-code 'set-r rrr right)))))))
|
|
|
225
|
|
|
226 (defun ccl-compile-self-set (cmd)
|
|
|
227 (let ((rrr (ccl-check-register (car cmd) cmd))
|
|
|
228 (right (nth 2 cmd)))
|
|
|
229 (if (listp right)
|
|
|
230 ;; cmd == (RRR SELF-OP= (XXX OP YYY))
|
|
|
231 (progn
|
|
|
232 (ccl-compile-expression 'r7 right)
|
|
|
233 (setq right 'r7)))
|
|
|
234 (ccl-compile-expression
|
|
|
235 rrr
|
|
|
236 (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right))))
|
|
|
237
|
|
|
238 (defun ccl-compile-expression (rrr expr)
|
|
|
239 (let ((left (car expr))
|
|
|
240 (right (nth 2 expr)))
|
|
|
241 (if (listp left)
|
|
|
242 (progn
|
|
|
243 (ccl-compile-expression 'r7 left)
|
|
|
244 (setq left 'r7)))
|
|
|
245 (if (eq rrr left)
|
|
|
246 (if (integer-or-char-p right)
|
|
|
247 (if (< right 32768)
|
|
|
248 (ccl-embed-code 'set-self-cs rrr right)
|
|
|
249 (ccl-embed-code 'set-self-cl rrr 0)
|
|
|
250 (ccl-embed-const right))
|
|
|
251 (ccl-check-register right expr)
|
|
|
252 (ccl-embed-code 'set-self-r rrr (get right 'ccl-register-number)))
|
|
|
253 (if (integer-or-char-p right)
|
|
|
254 (progn
|
|
|
255 (ccl-embed-code 'set-expr-cl rrr (get left 'ccl-register-number))
|
|
|
256 (ccl-embed-const right))
|
|
|
257 (ccl-check-register right expr)
|
|
|
258 (ccl-embed-code 'set-expr-r rrr (get left 'ccl-register-number))
|
|
|
259 (ccl-embed-const (get right 'ccl-register-number))))
|
|
|
260 (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code))))
|
|
|
261
|
|
|
262 (defun ccl-compile-write-string (cmd)
|
|
|
263 (if (/= (length cmd) 2)
|
|
|
264 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
265 (let* ((str (nth 1 cmd))
|
|
|
266 (len (length str))
|
|
|
267 (i 0))
|
|
|
268 (ccl-embed-code 'write-s 0 0)
|
|
|
269 (ccl-embed-const len)
|
|
|
270 (while (< i len)
|
|
|
271 (ccl-embed-const (aref str i))
|
|
|
272 (setq i (1+ i)))))
|
|
|
273
|
|
|
274 (defun ccl-compile-if (cmd)
|
|
|
275 (if (and (/= (length cmd) 3) (/= (length cmd) 4))
|
|
|
276 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
277 (let ((condition (nth 1 cmd))
|
|
|
278 (true-cmds (nth 2 cmd))
|
|
|
279 (false-cmds (nth 3 cmd))
|
|
|
280 ic0 ic1 ic2)
|
|
|
281 (if (listp condition)
|
|
|
282 ;; cmd == (if (XXX OP YYY) ...)
|
|
|
283 (if (listp (car condition))
|
|
|
284 ;; cmd == (if ((xxx op yyy) OP YYY) ...)
|
|
|
285 (progn
|
|
|
286 (ccl-compile-expression 'r7 (car condition))
|
|
|
287 (setq condition (cons 'r7 (cdr condition)))
|
|
|
288 (setq cmd (cons (car cmd)
|
|
|
289 (cons condition
|
|
|
290 (cdr (cdr cmd))))))))
|
|
|
291 (setq ic0 ccl-current-ic)
|
|
|
292 (ccl-embed-nop (if (listp condition) 3 1))
|
|
|
293 (ccl-compile-1 true-cmds)
|
|
|
294 (if (null false-cmds)
|
|
|
295 (setq ic1 ccl-current-ic)
|
|
|
296 (setq ic2 ccl-current-ic)
|
|
|
297 (ccl-embed-const 0)
|
|
|
298 (setq ic1 ccl-current-ic)
|
|
|
299 (ccl-compile-1 false-cmds)
|
|
|
300 (ccl-embed-code 'jump 0 ccl-current-ic ic2))
|
|
|
301 (if (symbolp condition)
|
|
|
302 (ccl-embed-code 'jump-cond condition ic1 ic0)
|
|
|
303 (let ((arg (nth 2 condition)))
|
|
|
304 (if (integer-or-char-p arg)
|
|
|
305 (progn
|
|
|
306 (ccl-embed-code 'jump-cond-c (car condition) ic1 ic0)
|
|
|
307 (ccl-embed-const arg (1+ ic0)))
|
|
|
308 (ccl-check-register arg cmd)
|
|
|
309 (ccl-embed-code 'jump-cond-r (car condition) ic1 ic0)
|
|
|
310 (ccl-embed-const (get arg 'ccl-register-number) (1+ ic0)))
|
|
|
311 (ccl-embed-const (get (nth 1 condition) 'ccl-arith-code) (+ ic0 2))))))
|
|
|
312
|
|
|
313 (defun ccl-compile-branch (cmd)
|
|
|
314 (if (< (length cmd) 3)
|
|
|
315 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
316 (if (listp (nth 1 cmd))
|
|
|
317 (progn
|
|
|
318 (ccl-compile-expression 'r7 (nth 1 cmd))
|
|
|
319 (setq cmd (cons (car cmd)
|
|
|
320 (cons 'r7 (cdr (cdr cmd)))))))
|
|
|
321 (ccl-compile-branch-1 cmd))
|
|
|
322
|
|
|
323 (defun ccl-compile-read-branch (cmd)
|
|
|
324 (ccl-compile-branch-1 cmd))
|
|
|
325
|
|
|
326 (defun ccl-compile-branch-1 (cmd)
|
|
|
327 (if (< (length cmd) 3)
|
|
|
328 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
329 (let ((rrr (ccl-check-register (car (cdr cmd)) cmd))
|
|
|
330 (branches (cdr (cdr cmd)))
|
|
|
331 i ic0 ic1 ic2
|
|
|
332 branch-tails)
|
|
|
333 (ccl-embed-code (car cmd) rrr (- (length cmd) 2))
|
|
|
334 (setq ic0 ccl-current-ic)
|
|
|
335 (ccl-embed-nop (1- (length cmd)))
|
|
|
336 (setq i 0)
|
|
|
337 (while branches
|
|
|
338 (ccl-embed-const ccl-current-ic (+ ic0 i))
|
|
|
339 (ccl-compile-1 (car branches))
|
|
|
340 (setq branch-tails (cons ccl-current-ic branch-tails))
|
|
|
341 (ccl-embed-nop)
|
|
|
342 (setq i (1+ i))
|
|
|
343 (setq branches (cdr branches)))
|
|
|
344 ;; We don't need `jump' from the last branch.
|
|
|
345 (setq branch-tails (cdr branch-tails))
|
|
|
346 (setq ccl-current-ic (1- ccl-current-ic))
|
|
|
347 (while branch-tails
|
|
|
348 (ccl-embed-code 'jump 0 ccl-current-ic (car branch-tails))
|
|
|
349 (setq branch-tails (cdr branch-tails)))
|
|
|
350 ;; This is the case `rrr' is out of range.
|
|
|
351 (ccl-embed-const ccl-current-ic (+ ic0 i))
|
|
|
352 ))
|
|
|
353
|
|
|
354 (defun ccl-compile-loop (cmd)
|
|
|
355 (if (< (length cmd) 2)
|
|
|
356 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
357 (let ((ccl-loop-head ccl-current-ic)
|
|
|
358 (ccl-breaks nil))
|
|
|
359 (setq cmd (cdr cmd))
|
|
|
360 (while cmd
|
|
|
361 (ccl-compile-1 (car cmd))
|
|
|
362 (setq cmd (cdr cmd)))
|
|
|
363 (while ccl-breaks
|
|
|
364 (ccl-embed-code 'jump 0 ccl-current-ic (car ccl-breaks))
|
|
|
365 (setq ccl-breaks (cdr ccl-breaks)))))
|
|
|
366
|
|
|
367 (defun ccl-compile-break (cmd)
|
|
|
368 (if (/= (length cmd) 1)
|
|
|
369 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
370 (if (null ccl-loop-head)
|
|
|
371 (error "CCL: No outer loop: %s" cmd))
|
|
|
372 (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
|
|
|
373 (ccl-embed-nop))
|
|
|
374
|
|
|
375 (defun ccl-compile-repeat (cmd)
|
|
|
376 (if (/= (length cmd) 1)
|
|
|
377 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
378 (if (null ccl-loop-head)
|
|
|
379 (error "CCL: No outer loop: %s" cmd))
|
|
|
380 (ccl-embed-code 'jump 0 ccl-loop-head))
|
|
|
381
|
|
|
382 (defun ccl-compile-write-repeat (cmd)
|
|
|
383 (if (/= (length cmd) 2)
|
|
|
384 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
385 (if (null ccl-loop-head)
|
|
|
386 (error "CCL: No outer loop: %s" cmd))
|
|
|
387 (let ((arg (nth 1 cmd)))
|
|
|
388 (cond ((integer-or-char-p arg)
|
|
|
389 (ccl-embed-code 'write-c-jump 0 ccl-loop-head)
|
|
|
390 (ccl-embed-const arg))
|
|
|
391 ((stringp arg)
|
|
|
392 (ccl-embed-code 'write-s-jump 0 ccl-loop-head)
|
|
|
393 (let ((i 0) (len (length arg)))
|
|
|
394 (ccl-embed-const (length arg))
|
|
|
395 (while (< i len)
|
|
|
396 (ccl-embed-const (aref arg i))
|
|
|
397 (setq i (1+ i)))))
|
|
|
398 (t
|
|
|
399 (ccl-check-register arg cmd)
|
|
|
400 (ccl-embed-code 'write-jump arg ccl-loop-head)))))
|
|
|
401
|
|
|
402 (defun ccl-compile-write-read-repeat (cmd)
|
|
|
403 (if (or (< (length cmd) 2) (> (length cmd) 3))
|
|
|
404 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
405 (if (null ccl-loop-head)
|
|
|
406 (error "CCL: No outer loop: %s" cmd))
|
|
|
407 (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
|
|
|
408 (arg (nth 2 cmd)))
|
|
|
409 (cond ((null arg)
|
|
|
410 (ccl-embed-code 'write-read-jump rrr ccl-loop-head))
|
|
|
411 ((integer-or-char-p arg)
|
|
|
412 (ccl-embed-code 'write-c-read-jump rrr ccl-loop-head)
|
|
|
413 (ccl-embed-const arg))
|
|
|
414 ((or (stringp arg) (vectorp arg))
|
|
|
415 (ccl-embed-code (if (stringp arg)
|
|
|
416 'write-s-read-jump
|
|
|
417 'write-a-read-jump)
|
|
|
418 rrr ccl-loop-head)
|
|
|
419 (let ((i 0) (len (length arg)))
|
|
|
420 (ccl-embed-const (length arg))
|
|
|
421 (while (< i len)
|
|
|
422 (ccl-embed-const (aref arg i))
|
|
|
423 (setq i (1+ i)))))
|
|
|
424 (t (error "CCL: Invalide argument %s: %s" arg cmd)))))
|
|
|
425
|
|
|
426 (defun ccl-compile-read (cmd)
|
|
|
427 (let ((rrr (ccl-check-register (nth 1 cmd) cmd)))
|
|
|
428 (cond ((= (length cmd) 2)
|
|
|
429 (ccl-embed-code 'read1 rrr 0))
|
|
|
430 ((= (length cmd) 3)
|
|
|
431 (ccl-embed-code 'read2 rrr (get (nth 2 cmd) 'ccl-register-number)))
|
|
|
432 (t (error "CCL: Invalid number of arguments: %s" cmd)))))
|
|
|
433
|
|
|
434 (defun ccl-compile-read-if (cmd)
|
|
|
435 (if (and (/= (length cmd) 3) (/= (length cmd) 4))
|
|
|
436 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
437 (let* ((expr (nth 1 cmd))
|
|
|
438 (rrr (ccl-check-register (car expr) cmd))
|
|
|
439 (true-cmds (nth 2 cmd))
|
|
|
440 (false-cmds (nth 3 cmd))
|
|
|
441 ic0 ic1 ic2)
|
|
|
442 (setq ic0 ccl-current-ic)
|
|
|
443 (ccl-embed-nop 3)
|
|
|
444 (ccl-compile-1 true-cmds)
|
|
|
445 (if (null false-cmds)
|
|
|
446 (setq ic1 ccl-current-ic)
|
|
|
447 (setq ic2 ccl-current-ic)
|
|
|
448 (ccl-embed-const 0)
|
|
|
449 (setq ic1 ccl-current-ic)
|
|
|
450 (ccl-compile-1 false-cmds)
|
|
|
451 (ccl-embed-code 'jump 0 ccl-current-ic ic2))
|
|
|
452 (let ((arg (nth 2 expr)))
|
|
|
453 (ccl-embed-code (if (integer-or-char-p arg) 'read-jump-cond-c
|
|
|
454 'read-jump-cond-r)
|
|
|
455 rrr ic1 ic0)
|
|
|
456 (ccl-embed-const (if (integer-or-char-p arg) arg
|
|
|
457 (get arg 'ccl-register-number))
|
|
|
458 (1+ ic0))
|
|
|
459 (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code) (+ ic0 2)))))
|
|
|
460
|
|
|
461 (defun ccl-compile-write (cmd)
|
|
|
462 (if (and (/= (length cmd) 2) (/= (length cmd) 3))
|
|
|
463 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
464 (let ((rrr (nth 1 cmd)))
|
|
|
465 (cond ((integer-or-char-p rrr)
|
|
|
466 (ccl-embed-code 'write-c 0 0)
|
|
|
467 (ccl-embed-const rrr))
|
|
|
468 ((stringp rrr)
|
|
|
469 (ccl-compile-write-string (list 'write rrr)))
|
|
|
470 (t
|
|
|
471 (ccl-check-register rrr cmd)
|
|
|
472 (let ((arg (nth 2 cmd)))
|
|
|
473 (if arg
|
|
|
474 (cond ((symbolp arg)
|
|
|
475 (ccl-check-register arg cmd)
|
|
|
476 (ccl-embed-code 'write2 rrr
|
|
|
477 (get arg 'ccl-register-number)))
|
|
|
478 ((vectorp arg)
|
|
|
479 (let ((i 0) (len (length arg)))
|
|
|
480 (ccl-embed-code 'write-a rrr 0)
|
|
|
481 (ccl-embed-const len)
|
|
|
482 (while (< i len)
|
|
|
483 (ccl-embed-const (aref arg i))
|
|
|
484 (setq i (1+ i)))))
|
|
|
485 (t (error "CCL: Invalid argument %s: %s" arg cmd)))
|
|
|
486 (ccl-embed-code 'write1 rrr 0)))))))
|
|
|
487
|
|
|
488 (defun ccl-compile-end (cmd)
|
|
|
489 (if (/= (length cmd) 1)
|
|
|
490 (error "CCL: Invalid number of arguments: %s" cmd))
|
|
|
491 (ccl-embed-code 'end 0 0))
|
|
|
492
|
|
|
493 ;;; CCL dump staffs
|
|
|
494 (defvar ccl-program-vector-dump nil)
|
|
|
495
|
|
|
496 ;;;###autoload
|
|
|
497 (defun ccl-dump (ccl-code)
|
|
|
498 "Disassemble compiled CCL-CODE."
|
|
|
499 (save-excursion
|
|
|
500 (set-buffer (get-buffer-create "*CCL-Dump*"))
|
|
|
501 (erase-buffer)
|
|
|
502 (setq ccl-program-vector-dump ccl-code)
|
|
|
503 (let ((len (length ccl-code)))
|
|
|
504 (insert "Main:\n")
|
|
|
505 (setq ccl-current-ic 1)
|
|
|
506 (if (> (aref ccl-code 0) 0)
|
|
|
507 (progn
|
|
|
508 (while (< ccl-current-ic (aref ccl-code 0))
|
|
|
509 (ccl-dump-1))
|
|
|
510 (insert "At EOF:\n")))
|
|
|
511 (while (< ccl-current-ic len)
|
|
|
512 (ccl-dump-1))
|
|
|
513 ))
|
|
|
514 (display-buffer (get-buffer "*CCL-Dump*")))
|
|
|
515
|
|
|
516 (defun ccl-get-next-code ()
|
|
|
517 (prog1
|
|
|
518 (aref ccl-program-vector-dump ccl-current-ic)
|
|
|
519 (setq ccl-current-ic (1+ ccl-current-ic))))
|
|
|
520
|
|
|
521 (defun ccl-dump-1 ()
|
|
|
522 (let* ((opcode (ccl-get-next-code))
|
|
|
523 (code (logand opcode 31))
|
|
|
524 (cmd (aref ccl-machine-code-table code))
|
|
|
525 (rrr (logand (ash opcode -5) 7))
|
|
|
526 (cc (ash opcode -8)))
|
|
|
527 (insert (format "%4d: " (1- ccl-current-ic)))
|
|
|
528 (funcall (get cmd 'ccl-dump-function) rrr cc)))
|
|
|
529
|
|
|
530 (defun ccl-dump-set-cs (rrr cc)
|
|
|
531 (insert (format "r%d = %s\n" rrr cc)))
|
|
|
532
|
|
|
533 (defun ccl-dump-set-cl (rrr cc)
|
|
|
534 (setq cc (ccl-get-next-code))
|
|
|
535 (insert (format "r%d = %s\n" rrr cc)))
|
|
|
536
|
|
|
537 (defun ccl-dump-set-r (rrr cc)
|
|
|
538 (insert (format "r%d = r%d\n" rrr cc)))
|
|
|
539
|
|
|
540 (defun ccl-dump-set-a (rrr cc)
|
|
|
541 (let ((range (ccl-get-next-code)) (i 0))
|
|
|
542 (insert (format "r%d = array[r%d] of length %d\n\t"
|
|
|
543 rrr cc range))
|
|
|
544 (let ((i 0))
|
|
|
545 (while (< i range)
|
|
|
546 (insert (format "%d " (ccl-get-next-code)))
|
|
|
547 (setq i (1+ i))))
|
|
|
548 (insert "\n")))
|
|
|
549
|
|
|
550 (defun ccl-dump-jump (rrr cc)
|
|
|
551 (insert (format "jump to %d\n" cc)))
|
|
|
552
|
|
|
553 (defun ccl-dump-jump-cond (rrr cc)
|
|
|
554 (insert (format "if !(r%d), jump to %d\n" rrr cc)))
|
|
|
555
|
|
|
556 (defun ccl-dump-write-jump (rrr cc)
|
|
|
557 (insert (format "write r%d, jump to %d\n" rrr cc)))
|
|
|
558
|
|
|
559 (defun ccl-dump-write-read-jump (rrr cc)
|
|
|
560 (insert (format "write r%d, read r%d, jump to %d\n" rrr rrr cc)))
|
|
|
561
|
|
|
562 (defun ccl-dump-write-c-jump (rrr cc)
|
|
|
563 (let ((const (ccl-get-next-code)))
|
|
|
564 (insert (format "write %s, jump to %d\n" const cc))))
|
|
|
565
|
|
|
566 (defun ccl-dump-write-c-read-jump (rrr cc)
|
|
|
567 (let ((const (ccl-get-next-code)))
|
|
|
568 (insert (format "write %s, read r%d, jump to %d\n" const rrr cc))))
|
|
|
569
|
|
|
570 (defun ccl-dump-write-s-jump (rrr cc)
|
|
|
571 (let ((len (ccl-get-next-code)) (i 0))
|
|
|
572 (insert "write \"")
|
|
|
573 (while (< i len)
|
|
|
574 (insert (format "%c" (ccl-get-next-code)))
|
|
|
575 (setq i (1+ i)))
|
|
|
576 (insert (format "\", jump to %d\n" cc))))
|
|
|
577
|
|
|
578 (defun ccl-dump-write-s-read-jump (rrr cc)
|
|
|
579 (let ((len (ccl-get-next-code)) (i 0))
|
|
|
580 (insert "write \"")
|
|
|
581 (while (< i len)
|
|
|
582 (insert (format "%c" (ccl-get-next-code)))
|
|
|
583 (setq i (1+ i)))
|
|
|
584 (insert (format "\", read r%d, jump to %d\n" rrr cc))))
|
|
|
585
|
|
|
586 (defun ccl-dump-write-a-read-jump (rrr cc)
|
|
|
587 (let ((len (ccl-get-next-code)) (i 0))
|
|
|
588 (insert (format "write array[r%d] of length %d, read r%d, jump to %d\n\t"
|
|
|
589 rrr len rrr cc))
|
|
|
590 (while (< i len)
|
|
|
591 (insert (format "%d " (ccl-get-next-code)))
|
|
|
592 (setq i (1+ i)))
|
|
|
593 (insert "\n")))
|
|
|
594
|
|
|
595 (defun ccl-dump-branch (rrr cc)
|
|
|
596 (let ((i 0))
|
|
|
597 (insert (format "jump to array[r%d] of length %d)\n\t" rrr cc))
|
|
|
598 (while (<= i cc)
|
|
|
599 (insert (format "%d " (ccl-get-next-code)))
|
|
|
600 (setq i (1+ i)))
|
|
|
601 (insert "\n")))
|
|
|
602
|
|
|
603 (defun ccl-dump-read1 (rrr cc)
|
|
|
604 (insert (format "read r%d\n" rrr)))
|
|
|
605
|
|
|
606 (defun ccl-dump-read2 (rrr cc)
|
|
|
607 (insert (format "read r%d and r%d\n" rrr cc)))
|
|
|
608
|
|
|
609 (defun ccl-dump-read-branch (rrr cc)
|
|
|
610 (insert (format "read r%d, " rrr))
|
|
|
611 (ccl-dump-branch rrr cc))
|
|
|
612
|
|
|
613 (defun ccl-dump-write1 (rrr cc)
|
|
|
614 (insert (format "write r%d\n" rrr)))
|
|
|
615
|
|
|
616 (defun ccl-dump-write2 (rrr cc)
|
|
|
617 (insert (format "write r%d and r%d\n" rrr cc)))
|
|
|
618
|
|
|
619 (defun ccl-dump-write-c (rrr cc)
|
|
|
620 (insert (format "write %s\n" (ccl-get-next-code))))
|
|
|
621
|
|
|
622 (defun ccl-dump-write-s (rrr cc)
|
|
|
623 (let ((len (ccl-get-next-code)) (i 0))
|
|
|
624 (insert "write \"")
|
|
|
625 (while (< i len)
|
|
|
626 (insert (format "%c" (ccl-get-next-code)))
|
|
|
627 (setq i (1+ i)))
|
|
|
628 (insert "\"\n")))
|
|
|
629
|
|
|
630 (defun ccl-dump-write-a (rrr cc)
|
|
|
631 (let ((len (ccl-get-next-code)) (i 0))
|
|
|
632 (insert (format "write array[r%d] of length %d\n\t" rrr len))
|
|
|
633 (while (< i 0)
|
|
|
634 (insert "%d " (ccl-get-next-code))
|
|
|
635 (setq i (1+ i)))
|
|
|
636 (insert "\n")))
|
|
|
637
|
|
|
638 (defun ccl-dump-end (rrr cc)
|
|
|
639 (insert "end\n"))
|
|
|
640
|
|
|
641 (defun ccl-dump-set-self-cs (rrr cc)
|
|
|
642 (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
643 (insert (format "r%d %s= %s\n" rrr arith cc))))
|
|
|
644
|
|
|
645 (defun ccl-dump-set-self-cl (rrr cc)
|
|
|
646 (setq cc (ccl-get-next-code))
|
|
|
647 (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
648 (insert (format "r%d %s= %s\n" rrr arith cc))))
|
|
|
649
|
|
|
650 (defun ccl-dump-set-self-r (rrr cc)
|
|
|
651 (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
652 (insert (format "r%d %s= r%d\n" rrr arith cc))))
|
|
|
653
|
|
|
654 (defun ccl-dump-set-expr-cl (rrr cc)
|
|
|
655 (let ((const (ccl-get-next-code))
|
|
|
656 (arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
657 (insert (format "r%d = r%d %s %s\n" rrr cc arith const))))
|
|
|
658
|
|
|
659 (defun ccl-dump-set-expr-r (rrr cc)
|
|
|
660 (let ((reg (ccl-get-next-code))
|
|
|
661 (arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
662 (insert (format "r%d = r%d %s r%d\n" rrr cc arith reg))))
|
|
|
663
|
|
|
664 (defun ccl-dump-jump-cond-c (rrr cc)
|
|
|
665 (let ((const (ccl-get-next-code))
|
|
|
666 (arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
667 (insert (format "if !(r%d %s %s), jump to %d\n" rrr arith const cc))))
|
|
|
668
|
|
|
669 (defun ccl-dump-jump-cond-r (rrr cc)
|
|
|
670 (let ((reg (ccl-get-next-code))
|
|
|
671 (arith (aref ccl-arith-table (ccl-get-next-code))))
|
|
|
672 (insert (format "if !(r%d %s r%d), jump to %d\n" rrr arith reg cc))))
|
|
|
673
|
|
|
674 (defun ccl-dump-read-jump-cond-c (rrr cc)
|
|
|
675 (insert (format "read r%d, " rrr))
|
|
|
676 (ccl-dump-jump-cond-c rrr cc))
|
|
|
677
|
|
|
678 (defun ccl-dump-read-jump-cond-r (rrr cc)
|
|
|
679 (insert (format "read r%d, " rrr))
|
|
|
680 (ccl-dump-jump-cond-r rrr cc))
|
|
|
681
|
|
|
682 ;; CCL emulation staffs
|
|
|
683
|
|
|
684 ;; Not yet implemented.
|
|
|
685
|
|
|
686 ;; For byte-compiler
|
|
|
687
|
|
|
688 ;;;###autoload
|
|
|
689 (defmacro define-ccl-program (name ccl-program &optional doc)
|
|
|
690 "Does (defconst NAME (ccl-compile (eval CCL-PROGRAM)) DOC).
|
|
|
691 Byte-compiler expand this macro while compiling."
|
|
|
692 (` (defconst (, name) (, (ccl-compile (eval ccl-program))) (, doc))))
|
|
|
693
|
|
|
694 (put 'define-ccl-program 'byte-hunk-handler 'macroexpand)
|
|
|
695
|
|
|
696 (provide 'ccl)
|
