1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
;;; ccl-tests.el --- unit tests for ccl.el -*- lexical-binding:t -*-
;; Copyright (C) 2018-2025 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
(require 'ert)
(require 'ccl)
(require 'seq)
(ert-deftest shift ()
(with-suppressed-warnings ((suspicious lsh))
;; shift left +ve 5628 #x00000000000015fc
(should (= (ash 5628 8) 1440768)) ; #x000000000015fc00
(should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00
;; shift left -ve -5628 #x3fffffffffffea04
(should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400
(should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400
;; shift right +ve 5628 #x00000000000015fc
(should (= (ash 5628 -8) 21)) ; #x0000000000000015
(should (= (lsh 5628 -8) 21)) ; #x0000000000000015
;; shift right -ve -5628 #x3fffffffffffea04
(should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea
(should (= (lsh -5628 -8)
(ash (- -5628 (ash most-negative-fixnum 1)) -8)
(ash (logand (ash -5628 -1) most-positive-fixnum) -7)))))
;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el
(defconst prog-pgg-source
'(1
((loop
(read r0) (r1 ^= r0) (r2 ^= 0)
(r5 = 0)
(loop
(r1 <<= 1)
(r1 += ((r2 >> 15) & 1))
(r2 <<= 1)
(if (r1 & 256)
((r1 ^= 390) (r2 ^= 19707)))
(if (r5 < 7)
((r5 += 1)
(repeat))))
(repeat)))))
(defconst prog-pgg-code
[1 30 14 114744 114775 0 161 131127 1 148217 15 82167
1 1848 131159 1 1595 5 256 114743 390 114775 19707
1467 16 7 183 1 -5628 -7164 22])
(defconst prog-pgg-dump
"Out-buffer must be as large as in-buffer.
Main-body:
2:[read-register] read r0 (0 remaining)
3:[set-assign-expr-register] r1 ^= r0
4:[set-assign-expr-const] r2 ^= 0
6:[set-short-const] r5 = 0
7:[set-assign-expr-const] r1 <<= 1
9:[set-expr-const] r7 = r2 >> 15
11:[set-assign-expr-const] r7 &= 1
13:[set-assign-expr-register] r1 += r7
14:[set-assign-expr-const] r2 <<= 1
16:[jump-cond-expr-const] if !(r1 & 256), jump to 23(+7)
19:[set-assign-expr-const] r1 ^= 390
21:[set-assign-expr-const] r2 ^= 19707
23:[jump-cond-expr-const] if !(r5 < 7), jump to 29(+6)
26:[set-assign-expr-const] r5 += 1
28:[jump] jump to 7(-21)
29:[jump] jump to 2(-27)
At EOF:
30:[end] end
")
(ert-deftest ccl-compile-pgg ()
(should (equal (ccl-compile prog-pgg-source) prog-pgg-code)))
(ert-deftest ccl-dump-pgg ()
(with-temp-buffer
(ccl-dump prog-pgg-code)
(should (equal (buffer-string) prog-pgg-dump))))
(defvar pgg-parse-crc24)
(declare-function pgg-parse-crc24-string "pgg-parse" (string))
(ert-deftest pgg-parse-crc24 ()
;; Compiler
(require 'pgg)
(should (equal pgg-parse-crc24 prog-pgg-code))
;; Interpreter
(should (equal (pgg-parse-crc24-string "foo") (concat [#x4f #xc2 #x55])))
(should (equal (pgg-parse-crc24-string "bar") (concat [#x51 #xd9 #x53])))
(should (equal (pgg-parse-crc24-string "baz") (concat [#xf0 #x58 #x6a]))))
(ert-deftest pgg-parse-crc24-dump ()
;; Disassembler
(require 'pgg)
(with-temp-buffer
(ccl-dump pgg-parse-crc24)
(should (equal (buffer-string) prog-pgg-dump))))
;;----------------------------------------------------------------------------
;; Program from 'midikbd-decoder in midi-kbd-0.2.el GNU ELPA package
(defconst prog-midi-source
'(2
(loop
(loop
;; central message receiver loop here.
;; When it exits, the command to deal with is in r0
;; Any arguments are in r1 and r2
;; r3 contains: 0 if no arguments are accepted
;; 1 if 1 argument can be accepted
;; 2 if 2 arguments can be accepted
;; 3 if the first of two arguments has been accepted
;; Arguments are read into r1 and r2.
;; r4 contains the current running status byte if any.
(read-if (r0 < #x80)
(branch r3
(repeat)
((r1 = r0) (r0 = r4) (break))
((r1 = r0) (r3 = 3) (repeat))
((r2 = r0) (r3 = 2) (r0 = r4) (break))))
(if (r0 >= #xf8) ; real time message
(break))
(if (r0 < #xf0) ; channel command
((r4 = r0)
(if ((r0 & #xe0) == #xc0)
;; program change and channel pressure take only 1 argument
(r3 = 1)
(r3 = 2))
(repeat)))
;; system common message, we swallow those for now
(r3 = 0)
(repeat))
(if ((r0 & #xf0) == #x90)
(if (r2 == 0) ; Some Midi devices use velocity 0
; for switching notes off,
; so translate into note-off
; and fall through
(r0 -= #x10)
((r0 &= #xf)
(write 0)
(write r0 r1 r2)
(repeat))))
(if ((r0 & #xf0) == #x80)
((r0 &= #xf)
(write 1)
(write r0 r1 r2)
(repeat)))
(repeat))))
(defconst prog-midi-code
[2 72 4893 16 128 1133 5 6 9 12 16 -2556 32 1024 6660 32 865
-4092 64 609 1024 4868 795 20 248 3844 3099 16 240 128 82169
224 1275 18 192 353 260 609 -9468 97 -9980 82169 240 4091
18 144 1371 18 0 16407 16 1796 81943 15 20 529 305 81 -14588
82169 240 2555 18 128 81943 15 276 529 305 81 -17660 -17916 22])
(defconst prog-midi-dump
(concat "Out-buffer must be 2 times bigger than in-buffer.
Main-body:
2:[read-jump-cond-expr-const] read r0, if !(r0 < 128), jump to 22(+20)
5:[branch] jump to array[r3] of length 4
11 12 15 18 22 ""
11:[jump] jump to 2(-9)
12:[set-register] r1 = r0
13:[set-register] r0 = r4
14:[jump] jump to 41(+27)
15:[set-register] r1 = r0
16:[set-short-const] r3 = 3
17:[jump] jump to 2(-15)
18:[set-register] r2 = r0
19:[set-short-const] r3 = 2
20:[set-register] r0 = r4
21:[jump] jump to 41(+20)
22:[jump-cond-expr-const] if !(r0 >= 248), jump to 26(+4)
25:[jump] jump to 41(+16)
26:[jump-cond-expr-const] if !(r0 < 240), jump to 39(+13)
29:[set-register] r4 = r0
30:[set-expr-const] r7 = r0 & 224
32:[jump-cond-expr-const] if !(r7 == 192), jump to 37(+5)
35:[set-short-const] r3 = 1
36:[jump] jump to 38(+2)
37:[set-short-const] r3 = 2
38:[jump] jump to 2(-36)
39:[set-short-const] r3 = 0
40:[jump] jump to 2(-38)
41:[set-expr-const] r7 = r0 & 240
43:[jump-cond-expr-const] if !(r7 == 144), jump to 59(+16)
46:[jump-cond-expr-const] if !(r2 == 0), jump to 52(+6)
49:[set-assign-expr-const] r0 -= 16
51:[jump] jump to 59(+8)
52:[set-assign-expr-const] r0 &= 15
54:[write-const-string] write char \"\x00\"
55:[write-register] write r0 (2 remaining)
56:[write-register] write r1 (1 remaining)
57:[write-register] write r2 (0 remaining)
58:[jump] jump to 2(-56)
59:[set-expr-const] r7 = r0 & 240
61:[jump-cond-expr-const] if !(r7 == 128), jump to 71(+10)
64:[set-assign-expr-const] r0 &= 15
66:[write-const-string] write char \"\x01\"
67:[write-register] write r0 (2 remaining)
68:[write-register] write r1 (1 remaining)
69:[write-register] write r2 (0 remaining)
70:[jump] jump to 2(-68)
71:[jump] jump to 2(-69)
At EOF:
72:[end] end
"))
(ert-deftest ccl-compile-midi ()
(should (equal (ccl-compile prog-midi-source) prog-midi-code)))
(ert-deftest ccl-dump-midi ()
(with-temp-buffer
(ccl-dump prog-midi-code)
(should (equal (buffer-string) prog-midi-dump))))
(ert-deftest ccl-hash-table ()
(let ((sym (gensym))
(table (make-hash-table :test 'eq)))
(puthash 16 17 table)
(puthash 17 16 table)
(define-translation-hash-table sym table)
(let* ((prog `(2
((loop
(lookup-integer ,sym r0 r1)))))
(compiled (ccl-compile prog))
(registers [17 0 0 0 0 0 0 0]))
(ccl-execute compiled registers)
(should (equal registers [2 16 0 0 0 0 0 1])))))
;;; ccl-tests.el ends here
|
