Mercurial > hg > xemacs-beta
annotate tests/automated/ccl-tests.el @ 5146:88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-15 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (c_readonly):
* alloc.c (deadbeef_memory):
* alloc.c (make_compiled_function):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (noseeum_make_marker):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* casetab.c:
* casetab.c (print_case_table):
* console.c:
* console.c (print_console):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_multiple_value):
* eval.c (mark_multiple_value):
* events.c (deinitialize_event):
* events.c (print_event):
* events.c (event_equal):
* extents.c:
* extents.c (soe_dump):
* extents.c (soe_insert):
* extents.c (soe_delete):
* extents.c (soe_move):
* extents.c (extent_fragment_update):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* frame.c:
* frame.c (print_frame):
* free-hook.c:
* free-hook.c (check_free):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c:
* gui.c (copy_gui_item):
* hash.c:
* hash.c (NULL_ENTRY):
* hash.c (KEYS_DIFFER_P):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lrecord.h:
* lrecord.h (LISP_OBJECT_UID):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lstream.c (print_lstream):
* lstream.c (finalize_lstream):
* marker.c (print_marker):
* marker.c (marker_equal):
* mc-alloc.c (visit_all_used_page_headers):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* opaque.c (print_opaque):
* opaque.c (print_opaque_ptr):
* opaque.c (equal_opaque_ptr):
* print.c (internal_object_printer):
* print.c (enum printing_badness):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c:
* symbols.c (print_symbol_value_magic):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* window.c (print_window):
* window.c (debug_print_window):
(1) Make lrecord UID's have a separate UID space for each object.
Otherwise, with 20-bit UID's, we rapidly wrap around, especially
when common objects like conses and strings increment the UID value
for every object created. (Originally I tried making two UID spaces,
one for objects that always print readably and hence don't display
the UID, and one for other objects. But certain objects like markers
for which a UID is displayed are still generated rapidly enough that
UID overflow is a serious issue.) This also has the advantage of
making UID values smaller, hence easier to remember -- their main
purpose is to make it easier to keep track of different objects of
the same type when debugging code. Make sure we dump lrecord UID's
so that we don't have problems with pdumped and non-dumped objects
having the same UID.
(2) Display UID's consistently whenever an object (a) doesn't
consistently print readably (objects like cons and string, which
always print readably, can't display a UID), and (b) doesn't
otherwise have a unique property that makes objects of a
particular type distinguishable. (E.g. buffers didn't and still
don't print an ID, but the buffer name uniquely identifies the
buffer.) Some types, such as event, extent, compiled-function,
didn't always (or didn't ever) display an ID; others (such as
marker, extent, lstream, opaque, opaque-ptr, any object using
internal_object_printer()) used to display the actual machine
pointer instead.
(3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work
over all Lisp objects and take a Lisp object, not a struct pointer.
(4) Some misc cleanups in alloc.c, elhash.c.
(5) Change code in events.c that "deinitializes" an event so that
it doesn't increment the event UID counter in the process. Also
use deadbeef_memory() to overwrite memory instead of doing the same
with custom code. In the process, make deadbeef_memory() in
alloc.c always available, and delete extraneous copy in mc-alloc.c.
Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c
call deadbeef_memory().
(6) Resurrect "debug SOE" code in extents.c. Make it conditional
on DEBUG_XEMACS and on a `debug-soe' variable, rather than on
SOE_DEBUG. Make it output to stderr, not stdout.
(7) Delete some custom print methods that were identical to
external_object_printer().
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Mon, 15 Mar 2010 16:35:38 -0500 |
parents | 0f66906b6e37 |
children | 308d34e9f07d |
rev | line source |
---|---|
444 | 1 ;;; ccl-tests.el --- Testsuites on CCL ; -*- coding: iso-2022-7bit -*- |
2 | |
3 ;; Copyright (C) 2000 MIYASHITA Hisashi | |
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 Free | |
19 ;; Software Foundation,59 Temple Place - Suite 330, | |
20 ;; Boston, MA 02111-1307, USA. | |
21 | |
22 ;;; Section 0. Useful functions to construct test suites. | |
23 | |
24 (defvar ccl-test-last-register-state nil) | |
25 | |
26 (defun ccl-test-register-ccl-program (sym prog) | |
27 (let ((compiled (ccl-compile prog))) | |
28 (register-ccl-program sym compiled) | |
29 compiled)) | |
30 | |
31 (defun ccl-test (prog &optional regs return-reg-idx) | |
32 (ccl-test-register-ccl-program | |
33 'ccl-test prog) | |
34 (cond ((< (length regs) 8) | |
35 (setq ccl-test-last-register-state | |
36 (apply #'vector (append regs (make-list (- 8 (length regs)) 0))))) | |
37 ((> (length regs) 8) | |
38 (setq ccl-test-last-register-state | |
39 (apply #'vector (subseq regs 0 8)))) | |
40 (t | |
41 (setq ccl-test-last-register-state | |
42 (apply #'vector regs)))) | |
43 (ccl-execute | |
44 'ccl-test | |
45 ccl-test-last-register-state) | |
46 (if (null return-reg-idx) | |
47 (setq return-reg-idx 0)) | |
48 (aref ccl-test-last-register-state return-reg-idx)) | |
49 | |
50 (defun ccl-test-on-stream (prog string | |
51 &optional not-check-coding-system) | |
52 (ccl-test-register-ccl-program | |
53 'ccl-test-decoder prog) | |
54 (setq ccl-test-last-register-state (make-vector 9 0)) | |
55 (let ((str2 | |
56 (ccl-execute-on-string | |
57 'ccl-test-decoder | |
58 ccl-test-last-register-state | |
59 string))) | |
60 (if (not not-check-coding-system) | |
61 (Assert (string= | |
62 str2 | |
63 (decode-coding-string | |
64 string 'ccl-test-coding-system)))) | |
65 str2)) | |
66 | |
67 (defvar ccl-test-symbol-idx 0) | |
68 (defun ccl-test-generate-symbol (idx) | |
69 (intern (format "ccl-test-map-sym-%d" idx))) | |
70 | |
71 (defun ccl-test-construct-map-structure (maps &optional idx) | |
72 (setq ccl-test-symbol-idx (if idx idx 0)) | |
73 (let (map result sym) | |
74 (while maps | |
75 (setq map (car maps) | |
76 maps (cdr maps)) | |
77 (cond ((vectorp map) | |
78 (setq sym (ccl-test-generate-symbol | |
79 ccl-test-symbol-idx) | |
80 ccl-test-symbol-idx | |
81 (1+ ccl-test-symbol-idx)) | |
82 (register-code-conversion-map | |
83 sym map) | |
84 (set sym map) | |
85 (setq result (cons sym result))) | |
86 | |
87 ((symbolp map) | |
88 (setq result (cons sym result))) | |
89 | |
90 ((consp map) | |
91 (setq result | |
92 (cons (ccl-test-construct-map-structure | |
93 map ccl-test-symbol-idx) | |
94 result))) | |
95 (t | |
96 (error "Unknown data:%S" map)))) | |
97 (nreverse result))) | |
98 | |
99 (defun ccl-test-map-multiple (val maps) | |
100 (ccl-test | |
101 `(0 ((map-multiple | |
102 r1 r0 | |
103 ,(ccl-test-construct-map-structure maps)))) | |
104 (list val)) | |
105 (cons (aref ccl-test-last-register-state 0) | |
106 (aref ccl-test-last-register-state 1))) | |
107 | |
108 (defun ccl-test-iterate-multiple-map (val maps) | |
109 (ccl-test | |
110 `(0 ((iterate-multiple-map | |
111 r1 r0 | |
112 ,@(ccl-test-construct-map-structure maps)))) | |
113 (list val)) | |
114 (cons (aref ccl-test-last-register-state 0) | |
115 (aref ccl-test-last-register-state 1))) | |
116 | |
117 (defun ccl-test-setup () | |
118 (define-ccl-program | |
119 ccl-test-decoder | |
4573
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
120 '(1 (loop |
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
121 (read r0) |
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
122 (write-repeat r0)))) |
444 | 123 (define-ccl-program |
124 ccl-test-encoder | |
4573
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
125 '(1 (loop |
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
126 (read r0) |
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
127 (write-repeat r0)))) |
771 | 128 (or (find-coding-system 'ccl-test-coding-system) |
129 (make-coding-system | |
130 'ccl-test-coding-system | |
131 'ccl | |
4573
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
132 "CCL TEST temporary coding-system." |
771 | 133 '(mnemonic "CCL-TEST" |
134 eol-type lf | |
4715
a357478dd457
Fix some test failures, mule-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4573
diff
changeset
|
135 safe-charsets t |
771 | 136 decode ccl-test-decoder |
137 encode ccl-test-encoder)))) | |
444 | 138 |
139 ;;; Section 1. arithmetic operations. | |
140 | |
141 (defun ccl-test-normal-expr () | |
142 ;; normal-expr | |
143 (let ((r0 0) (r1 10) (r2 20) (r3 21) (r4 7)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
144 (Assert (= (ccl-test '(0 ((r0 = ((((r1 * r2) + r3) % r4) << 2)))) |
444 | 145 (list r0 r1 r2 r3 r4)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
146 (ash (% (+ (* r1 r2) r3) r4) 2)))) |
444 | 147 |
148 (Assert (\= (ccl-test '(0 ((r2 = (r1 < 10)) | |
149 (r0 = (r2 > 10)))) | |
150 '(0 5)) | |
151 0)) | |
152 | |
153 (let ((r0 0) (r1 #x10FF) (r2 #xCC) (r3 #xE0)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
154 (Assert (= (ccl-test '(0 ((r0 = (((r1 & #xFF) ^ r2) | r3)))) |
444 | 155 (list r0 r1 r2 r3)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
156 (logior (logxor (logand r1 #xFF) r2) r3)))) |
444 | 157 |
158 ;; checking range of SJIS | |
159 ;; 81(40-7E, 80-FC), 82, 9F, E0, E1, EF | |
160 | |
161 (let ((hs '(#x81 #x82 #x9F #xE0 #xE1 #xEF)) | |
162 func high low) | |
163 (setq func | |
164 (lambda (high low) | |
165 (let (ch c1 c2) | |
166 (setq ch (split-char (decode-shift-jis-char | |
167 (cons high low)))) | |
168 (setq c1 (nth 1 ch) | |
169 c2 (nth 2 ch)) | |
170 (ccl-test '(0 ((r0 = (r1 de-sjis r2)))) | |
171 (list 0 high low)) | |
172 (Assert (and (= c1 (aref ccl-test-last-register-state 0)) | |
173 (= c2 (aref ccl-test-last-register-state 7)))) | |
174 (ccl-test '(0 ((r0 = (r1 en-sjis r2)))) | |
175 (list 0 c1 c2)) | |
176 (Assert (and (= high (aref ccl-test-last-register-state 0)) | |
177 (= low (aref ccl-test-last-register-state 7))))))) | |
178 (while (setq high (car hs)) | |
179 (setq hs (cdr hs)) | |
180 (setq low #x40) | |
181 (while (<= low #x7E) | |
182 (funcall func high low) | |
183 (setq low (1+ low))) | |
184 (setq low #x80) | |
185 (while (<= low #xFC) | |
186 (funcall func high low) | |
187 (setq low (1+ low))))) | |
188 | |
189 ;; self-expr | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
190 (Assert (= (ccl-test '(0 ((r0 += 20) |
444 | 191 (r0 *= 40) |
192 (r0 -= 15))) | |
193 '(100)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
194 (- (* (+ 100 20) 40) 15))) |
444 | 195 |
196 ;; ref. array | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
197 (Assert (= (ccl-test '(0 ((r0 = r0 [100 101 102 103 104]))) |
444 | 198 '(3)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
199 103))) |
444 | 200 |
201 ;;; Section 2. Simple read and write | |
202 (defun ccl-test-simple-read-and-write () | |
203 ;; constant | |
204 (let* ((str "1234567890abcdefghij") | |
205 (dum (make-string 1 ?X))) | |
206 (Assert | |
207 (string= (ccl-test-on-stream | |
208 `(,(length str) | |
209 ((loop (read r0) (write ,str)))) dum) | |
210 str))) | |
211 ;; register | |
212 (let* ((str "1234567890abcdefghij")) | |
213 (Assert | |
214 (string= (ccl-test-on-stream `(1 ((read r0) | |
215 (loop | |
216 (write r0) | |
217 (read r0) | |
218 (repeat)))) | |
219 str) | |
220 str)) | |
221 (Assert | |
222 (string= (ccl-test-on-stream `(1 ((read r0) | |
223 (loop | |
224 (write-read-repeat r0)))) | |
225 str) | |
226 str))) | |
227 | |
228 ;; expression | |
229 (let ((str "1234567890abcdefghij") | |
230 str2 i len) | |
231 (setq str2 "" | |
232 len (length str) | |
233 i 0) | |
234 (while (< i len) | |
235 (setq str2 (concat str2 (char-to-string | |
236 (+ (char-to-int (aref str i)) 3)))) | |
237 (setq i (1+ i))) | |
238 (Assert | |
239 (string= (ccl-test-on-stream `(1 ((read r0) | |
240 (loop | |
241 (write (r0 + 3)) | |
242 (read r0) | |
243 (repeat)))) | |
244 str) | |
245 str2)) | |
246 (Assert | |
247 (string= (ccl-test-on-stream `(1 ((read r0) | |
248 (loop | |
249 (r0 += 3) | |
250 (write-read-repeat r0)))) | |
251 str) | |
252 str2))) | |
253 | |
254 | |
255 ;; write via array | |
256 (let* ((str (mapconcat (lambda (x) (char-to-string (int-to-char x))) | |
257 '(0 1 2 3 4 5 6) ""))) | |
258 (Assert | |
259 (string= (ccl-test-on-stream | |
260 `(1 ((read r0) | |
261 (loop | |
262 (write r0 | |
263 ,(vector (make-char 'japanese-jisx0208 36 34) | |
264 (make-char 'japanese-jisx0208 36 36) | |
265 (make-char 'japanese-jisx0208 36 38) | |
266 (make-char 'japanese-jisx0208 36 40) | |
267 (make-char 'japanese-jisx0208 36 42) | |
268 (make-char 'japanese-jisx0208 36 43) | |
269 (make-char 'japanese-jisx0208 36 45) | |
270 (make-char 'japanese-jisx0208 36 47) | |
271 (make-char 'japanese-jisx0208 36 49) | |
272 (make-char 'japanese-jisx0208 36 51))) | |
273 (read r0) | |
274 (repeat)))) | |
275 str t) | |
276 (mapconcat #'char-to-string | |
277 (list (make-char 'japanese-jisx0208 36 34) | |
278 (make-char 'japanese-jisx0208 36 36) | |
279 (make-char 'japanese-jisx0208 36 38) | |
280 (make-char 'japanese-jisx0208 36 40) | |
281 (make-char 'japanese-jisx0208 36 42) | |
282 (make-char 'japanese-jisx0208 36 43) | |
283 (make-char 'japanese-jisx0208 36 45)) | |
284 ""))))) | |
285 | |
286 ;;; Section 3. read-multibyte-character, and write-multibyte-character | |
287 (defun ccl-test-read-write-multibyte-character () | |
288 ;; simple test. | |
289 (let* ((str (concat "LMDXXX..." | |
290 (mapconcat #'char-to-string | |
291 (list (make-char 'japanese-jisx0208 36 36) | |
292 (make-char 'japanese-jisx0208 36 36) | |
293 (make-char 'japanese-jisx0208 50 67) | |
294 (make-char 'japanese-jisx0208 56 58) | |
295 (make-char 'japanese-jisx0208 72 104) | |
296 (make-char 'japanese-jisx0208 36 108) | |
297 (make-char 'japanese-jisx0208 36 70) | |
298 (make-char 'japanese-jisx0208 36 45) | |
299 (make-char 'japanese-jisx0208 36 63) | |
300 (make-char 'japanese-jisx0208 33 35)) | |
301 "") | |
302 "..."))) | |
303 (Assert | |
304 (string= | |
305 (ccl-test-on-stream | |
306 `(1 ((loop | |
307 (read-multibyte-character r0 r1) | |
308 (write-multibyte-character r0 r1) | |
309 (repeat)))) | |
310 str t) | |
311 str))) | |
312 ;; | |
313 ) | |
314 | |
315 ;;; Section 4. CCL call | |
316 (defun ccl-test-ccl-call () | |
317 ;; set up | |
318 (define-ccl-program | |
319 ccl-test-sub1 | |
320 '(0 | |
321 ((r5 = ?z)))) | |
322 (define-ccl-program | |
323 ccl-test-sub2 | |
324 '(0 | |
325 ((call ccl-test-sub1) | |
326 (r0 = (r5 * 20))))) | |
327 (define-ccl-program | |
328 ccl-test-sub3 | |
329 '(1 | |
330 ((call ccl-test-sub2) | |
331 (write r5) | |
332 (write (r0 / 20))))) | |
333 (Assert (string= | |
334 (ccl-test-on-stream | |
335 '(1 ((loop (read r0) (call ccl-test-sub3)))) | |
336 "A") | |
337 "zz"))) | |
338 | |
339 ;;; Section 5. Map-instructions | |
340 (defun ccl-test-map-instructions () | |
341 ;; set up | |
342 (define-ccl-program | |
343 ccl-test-arith-1 | |
344 '(0 | |
345 ((r0 += 1000000)))) | |
346 | |
347 (define-ccl-program | |
348 ccl-test-lambda | |
349 '(0 | |
350 ((r0 = -3)))) | |
351 | |
352 (define-ccl-program | |
353 ccl-test-t | |
354 '(0 | |
355 ((r0 = -2)))) | |
356 | |
357 (define-ccl-program | |
358 ccl-test-nil | |
359 '(0 | |
360 ((r0 = -1)))) | |
361 | |
362 ;; 1-level normal 1 mapping | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
363 (Assert (equal |
444 | 364 (mapcar |
365 (lambda (val) | |
366 (ccl-test-map-multiple | |
367 val | |
368 '([100 1 2 3 4 5]))) | |
369 '(0 99 100 101 102 103 104 105 106 107)) | |
370 '((0 . -1) (99 . -1) | |
371 (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
372 (105 . -1) (106 . -1) (107 . -1)))) |
444 | 373 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
374 (Assert (equal |
444 | 375 (mapcar |
376 (lambda (val) | |
377 (ccl-test-iterate-multiple-map | |
378 val | |
379 '([100 1 2 3 4 5]))) | |
380 '(0 99 100 101 102 103 104 105 106 107)) | |
381 '((0 . -1) (99 . -1) | |
382 (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
383 (105 . -1) (106 . -1) (107 . -1)))) |
444 | 384 |
385 ;; 1-level normal 2 mappings | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
386 (Assert (equal |
444 | 387 (mapcar |
388 (lambda (val) | |
389 (ccl-test-map-multiple | |
390 val | |
391 '([100 1 2 nil 4 5] | |
392 [101 12 13 14 15 16 17]))) | |
393 '(0 99 100 101 102 103 104 105 106 107)) | |
394 '((0 . -1) (99 . -1) (1 . 0) (2 . 0) | |
395 (13 . 1) (4 . 0) (5 . 0) (16 . 1) (17 . 1) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
396 (107 . -1)))) |
444 | 397 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
398 (Assert (equal |
444 | 399 (mapcar |
400 (lambda (val) | |
401 (ccl-test-iterate-multiple-map | |
402 val | |
403 '([100 1 2 3 4 5] | |
404 [101 12 13 14 15 16 17]))) | |
405 '(0 99 100 101 102 103 104 105 106 107)) | |
406 '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (3 . 0) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
407 (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . -1)))) |
444 | 408 |
409 | |
410 ;; 1-level normal 7 mappings | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
411 (Assert (equal |
444 | 412 (mapcar |
413 (lambda (val) | |
414 (ccl-test-map-multiple | |
415 val | |
416 '([100 1 2 nil 4 5] | |
417 [101 12 13 14 15 16 17] | |
418 [1000 101 102 103 nil 105 106 nil 108] | |
419 [1005 1006 1007 1008 1009 1010 1011 1012] | |
420 [10005 10006 10007 10008 10009 10010 10011 10012] | |
421 [20000 20000 20001 20002 nil 20004 20005 20006] | |
422 [20003 30000 30010 30020 30030 30040 30050 30060] | |
423 ))) | |
424 '(0 99 100 101 102 103 104 105 106 107 | |
425 998 999 1000 1001 1002 1003 1004 1005 1006 1007 | |
426 9999 10000 10001 10002 10003 10004 | |
427 19999 20000 20001 20002 20003 20004 | |
428 20005 20006)) | |
429 '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0) | |
430 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1) | |
431 (999 . -1) (101 . 2) (102 . 2) (103 . 2) (1003 . -1) | |
432 (105 . 2) (106 . 2) (1007 . 3) (108 . 2) (9999 . -1) | |
433 (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1) | |
434 (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
435 (20002 . 5) (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5)))) |
444 | 436 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
437 (Assert (equal |
444 | 438 (mapcar |
439 (lambda (val) | |
440 (ccl-test-iterate-multiple-map | |
441 val | |
442 '([100 1 2 nil 4 5] | |
443 [101 12 13 14 15 16 17] | |
444 [1000 101 102 103 nil 105 106 nil 108] | |
445 [1005 1006 1007 1008 1009 1010 1011 1012] | |
446 [10005 10006 10007 10008 10009 10010 10011 10012] | |
447 [20000 20000 20001 20002 nil 20004 20005 20006] | |
448 [20003 30000 30010 30020 30030 30040 30050 30060] | |
449 ))) | |
450 '(0 99 100 101 102 103 104 105 106 107 | |
451 998 999 1000 1001 1002 1003 1004 1005 1006 1007 | |
452 9999 10000 10001 10002 10003 10004 | |
453 19999 20000 20001 20002 20003 20004 | |
454 20005 20006)) | |
455 '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0) | |
456 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1) | |
457 (999 . -1) (101 . 2) (102 . 2) (103 . 2) (1003 . -1) | |
458 (105 . 2) (106 . 2) (1007 . 3) (108 . 2) (9999 . -1) | |
459 (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1) | |
460 (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
461 (20002 . 5)(30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5)))) |
444 | 462 |
463 ;; 1-level 7 mappings including CCL call | |
464 | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
465 (Assert (equal |
444 | 466 (mapcar |
467 (lambda (val) | |
468 (ccl-test-map-multiple | |
469 val | |
470 '([100 1 2 nil 4 5] | |
471 [101 12 13 14 15 16 17] | |
472 [1000 101 ccl-test-arith-1 103 nil 105 106 ccl-test-nil 108] | |
473 [1005 1006 1007 1008 1009 ccl-test-lambda 1011 1012] | |
474 [10005 10006 10007 10008 10009 10010 10011 10012] | |
475 [20000 20000 20001 20002 nil 20004 20005 20006] | |
476 [20003 30000 30010 30020 30030 30040 30050 30060] | |
477 ))) | |
478 '(0 99 100 101 102 103 104 105 106 107 | |
479 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | |
480 9999 10000 10001 10002 10003 10004 | |
481 19999 20000 20001 20002 20003 20004 | |
482 20005 20006)) | |
483 '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0) | |
484 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1) | |
485 (999 . -1) (101 . 2) (1001001 . 2) (103 . 2) | |
486 (1003 . -1) (105 . 2) (106 . 2) (1007 . 3) (108 . 2) | |
487 (1009 . 3) (1009 . 3) (9999 . -1) (10000 . -1) | |
488 (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1) | |
489 (19999 . -1) (20000 . 5) (20001 . 5) (20002 . 5) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
490 (30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5)))) |
444 | 491 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
492 (Assert (equal |
444 | 493 (mapcar |
494 (lambda (val) | |
495 (ccl-test-iterate-multiple-map | |
496 val | |
497 '([100 1 2 nil 4 5] | |
498 [101 12 13 14 15 16 17] | |
499 [1000 101 ccl-test-arith-1 103 nil 105 106 ccl-test-nil 108] | |
500 [1005 1006 1007 1008 1009 ccl-test-lambda 1011 1012] | |
501 [10005 10006 10007 10008 10009 10010 10011 10012] | |
502 [20000 20000 20001 20002 nil 20004 20005 20006] | |
503 [20003 30000 30010 30020 30030 30040 30050 30060] | |
504 ))) | |
505 '(0 99 100 101 102 103 104 105 106 107 | |
506 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | |
507 9999 10000 10001 10002 10003 10004 | |
508 19999 20000 20001 20002 20003 20004 | |
509 20005 20006)) | |
510 '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0) | |
511 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1) | |
512 (999 . -1) (101 . 2) (1001001 . 0) (103 . 2) | |
513 (1003 . -1) (105 . 2) (106 . 2) (-1 . 0) (108 . 2) | |
514 (1009 . 3) (-3 . 0) (9999 . -1) (10000 . -1) | |
515 (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1) | |
516 (19999 . -1) (20000 . 5) (20001 . 5) (20002 . 5) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
517 (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5)))) |
444 | 518 |
519 ;; 3-level mappings | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
520 (Assert (equal |
444 | 521 (mapcar |
522 (lambda (val) | |
523 (ccl-test-map-multiple | |
524 val | |
525 '([100 1 2 nil 4 5] | |
526 [101 12 13 14 15 16 17] | |
527 [1000 101 102 103 nil 105 106 nil 108] | |
528 (([1005 1006 1007 1008 1009 1010 1011 1012] | |
529 [10005 10006 20007 20008 10009 10010 10011 10012]) | |
530 [20000 20000 20001 20002 nil 20004 20005 20006] | |
531 [1006 2006 2007 2008 2009 2010] | |
532 ([20003 30000 30010 30020 30030 30040 30050 30060])) | |
533 [t t 0 1000000] | |
534 [1008 1108 1109 1110 1111 1112 1113]))) | |
535 '(0 99 100 101 102 103 104 105 106 107 | |
536 998 999 1000 1001 1002 1003 1004 1005 1006 1007 | |
537 1008 1009 1010 1011 1012 1013 1014 | |
538 9999 10000 10001 10002 10003 10004 | |
539 10005 10006 10007 10008 10009 10010 | |
540 19999 20000 20001 20002 20003 20004 | |
541 20005 20006)) | |
542 '((0 . 11) (99 . 11) (1 . 0) (2 . 0) (13 . 1) | |
543 (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . 11) | |
544 (998 . 11) (999 . 11) (101 . 2) (102 . 2) | |
545 (103 . 2) (1003 . 11) (105 . 2) (106 . 2) | |
546 (1006 . 11) (108 . 2) (1108 . 12) (1109 . 12) | |
547 (1110 . 12) (1111 . 12) (1112 . 12) (1113 . 12) | |
548 (1014 . 11) (9999 . 11) (10000 . 11) (10001 . 11) | |
549 (10002 . 11) (10003 . 11) (10004 . 11) (10005 . 11) | |
550 (30040 . 10) (30050 . 10) (10008 . 11) (10009 . 11) | |
551 (10010 . 11) (19999 . 11) (20000 . 11) (20001 . 11) | |
552 (20002 . 11) (20003 . 11) (20004 . 11) (20005 . 11) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
553 (20006 . 11)))) |
444 | 554 |
555 | |
556 ;; 3-level mappings including CCL call | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
557 (Assert (equal |
444 | 558 (mapcar |
559 (lambda (val) | |
560 (ccl-test-map-multiple | |
561 val | |
562 '([100 1 2 nil 4 5] | |
563 [101 12 13 14 15 16 17] | |
564 [1000 101 102 103 nil ccl-test-arith-1 106 nil 108] | |
565 (([1005 1006 1007 1008 1009 1010 1011 ccl-test-arith-1 | |
566 70 71 72 73] | |
567 [10005 10006 20007 20008 10009 10010 10011 10012]) | |
568 [70 ccl-test-t ccl-test-lambda ccl-test-nil ccl-test-nil] | |
569 [72 lambda] | |
570 [20000 20000 20001 20002 nil 20004 20005 20006] | |
571 [1006 2006 2007 2008 2009 2010] | |
572 ([20003 30000 30010 ccl-test-arith-1 30030 30040 | |
573 ccl-test-arith-1 30060] | |
574 [1001010 50 51 52 53 54 55])) | |
575 [t t 0 1000000] | |
576 [t ccl-test-arith-1 0 10] | |
577 [1008 1108 1109 1110 1111 1112 1113]))) | |
578 '(0 99 100 101 102 103 104 105 106 107 | |
579 998 999 1000 1001 1002 1003 1004 1005 1006 1007 | |
580 1008 1009 1010 1011 1012 1013 1014 1015 1016 | |
581 9999 10000 10001 10002 10003 10004 | |
582 10005 10006 10007 10008 10009 10010 | |
583 19999 20000 20001 20002 20003 20004 | |
584 20005 20006)) | |
585 '((1000000 . 15) (99 . 14) (1 . 0) (2 . 0) (13 . 1) | |
586 (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . 14) (998 . 14) | |
587 (999 . 14) (101 . 2) (102 . 2) (103 . 2) (1003 . 14) | |
588 (1001004 . 2) (106 . 2) (1006 . 14) (108 . 2) (1108 . 16) | |
589 (1109 . 16) (1110 . 16) (51 . 13) (1112 . 16) (71 . 7) | |
590 (72 . 8) (1015 . 14) (1016 . 14) (9999 . 14) (10000 . 14) | |
591 (10001 . 14) (10002 . 14) (10003 . 14) (10004 . 14) | |
592 (10005 . 14) (30040 . 12) (1020008 . 12) (10008 . 14) | |
593 (10009 . 14) (10010 . 14) (19999 . 14) (20000 . 14) | |
594 (20001 . 14) (20002 . 14) (20003 . 14) (20004 . 14) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
595 (20005 . 14) (20006 . 14)))) |
444 | 596 ;; All map-instruction tests ends here. |
597 ) | |
598 | |
599 (defun ccl-test-suites () | |
600 (ccl-test-setup) | |
601 (ccl-test-normal-expr) | |
602 (ccl-test-simple-read-and-write) | |
603 (ccl-test-read-write-multibyte-character) | |
604 (ccl-test-ccl-call) | |
4573
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
605 (ccl-test-map-instructions) |
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
606 ;; Re-initialise the coding system: |
baf6c66f6f47
Correct the CCL programs used by the coding system in ccl-tests.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
771
diff
changeset
|
607 (ccl-test-setup)) |
444 | 608 |
609 ;;; start tests only when ccl-execute is enabled. | |
610 (if (fboundp 'ccl-execute) | |
611 (ccl-test-suites)) | |
612 | |
613 ;;; ccl-test.el ends here. |